f128074 · project-m36 · git.iko.soy

git.iko.soy/project-m36

on master help sign in

Client.hs + session compiling

f128074AgentM11 years ago

ProjectM36/Client.hs+165−84

compare with master

unifiedsplit

@@ -30,6 +30,9 @@ module ProjectM36.Client

30 Attribute(..),

31 attributesFromList,

32 createNodeId,

33+ createSessionAtCommit,

34+ createSessionAtHead,

35+ closeSession,

33 TransactionGraphOperator(..),

36 TransactionGraphOperator(..),

34 Atomable,

37 Atomable,

35 NodeId(..),

38 NodeId(..),

@@ -40,7 +43,6 @@ import qualified ProjectM36.Base as B

40import ProjectM36.Error

43import ProjectM36.Error

41import ProjectM36.StaticOptimizer

44import ProjectM36.StaticOptimizer

42import Control.Monad.State

45import Control.Monad.State

43−import ProjectM36.Transaction

44import qualified ProjectM36.RelationalExpression as RE

46import qualified ProjectM36.RelationalExpression as RE

45import ProjectM36.TransactionGraph

47import ProjectM36.TransactionGraph

46import ProjectM36.TransactionGraph.Persist

48import ProjectM36.TransactionGraph.Persist

@@ -63,6 +65,9 @@ import Control.Concurrent.MVar

63import qualified Data.Map as M

65import qualified Data.Map as M

64import Control.Distributed.Process.Serializable (Serializable)

66import Control.Distributed.Process.Serializable (Serializable)

65--import Control.Distributed.Process.Debug

67--import Control.Distributed.Process.Debug

68+import qualified STMContainers.Map as STMMap

69+import ProjectM36.Session

70+import ListT

67type Hostname = String

72type Hostname = String

@@ -84,9 +89,12 @@ defaultDatabaseName = "base"

85defaultRemoteConnectionInfo :: ConnectionInfo

90defaultRemoteConnectionInfo :: ConnectionInfo

86defaultRemoteConnectionInfo = RemoteProcessConnectionInfo defaultDatabaseName (createNodeId "127.0.0.1" defaultServerPort)

91defaultRemoteConnectionInfo = RemoteProcessConnectionInfo defaultDatabaseName (createNodeId "127.0.0.1" defaultServerPort)

92+

93+type Sessions = STMMap.Map SessionId Session

94+

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

96+data Connection = InProcessConnection PersistenceStrategy Sessions (TVar TransactionGraph) |

89− RemoteProcessConnection LocalNode ProcessId -- perhaps should reference the local node as well

97+ RemoteProcessConnection LocalNode ProcessId

91data ConnectionError = SetupDatabaseDirectoryError PersistenceError |

99data ConnectionError = SetupDatabaseDirectoryError PersistenceError |

92 IOExceptionError IOException |

100 IOExceptionError IOException |

@@ -109,16 +117,16 @@ connectProjectM36 :: ConnectionInfo -> IO (Either ConnectionError Connection)

109--create a new in-memory database/transaction graph

117--create a new in-memory database/transaction graph

110connectProjectM36 (InProcessConnectionInfo strat) = do

118connectProjectM36 (InProcessConnectionInfo strat) = do

111 freshUUID <- nextRandom

119 freshUUID <- nextRandom

112− let bootstrapContext = RE.basicDatabaseContext

120+ let bootstrapContext = RE.basicDatabaseContext

113− freshDiscon = newDisconnectedTransaction freshUUID bootstrapContext

114 freshGraph = bootstrapTransactionGraph freshUUID bootstrapContext

121 freshGraph = bootstrapTransactionGraph freshUUID bootstrapContext

115 case strat of

122 case strat of

116 --create date examples graph for now- probably should be empty context in the future

123 --create date examples graph for now- probably should be empty context in the future

117 NoPersistence -> do

124 NoPersistence -> do

118− tvar <- newTVarIO (freshDiscon, freshGraph)

125+ graphTvar <- newTVarIO freshGraph

126+ sessions <- STMMap.newIO

119− return $ Right $ InProcessConnection strat tvar

127+ return $ Right $ InProcessConnection strat sessions graphTvar

120− MinimalPersistence dbdir -> connectPersistentProjectM36 strat NoDiskSync dbdir freshDiscon freshGraph

128+ MinimalPersistence dbdir -> connectPersistentProjectM36 strat NoDiskSync dbdir freshGraph

121− CrashSafePersistence dbdir -> connectPersistentProjectM36 strat FsyncDiskSync dbdir freshDiscon freshGraph

129+ CrashSafePersistence dbdir -> connectPersistentProjectM36 strat FsyncDiskSync dbdir freshGraph

122

130

123connectProjectM36 (RemoteProcessConnectionInfo databaseName serverNodeId) = do

131connectProjectM36 (RemoteProcessConnectionInfo databaseName serverNodeId) = do

124 connStatus <- newEmptyMVar

132 connStatus <- newEmptyMVar

@@ -140,14 +148,13 @@ connectProjectM36 (RemoteProcessConnectionInfo databaseName serverNodeId) = do

140 liftIO $ putMVar connStatus (Right $ RemoteProcessConnection localNode serverProcessId)

148 liftIO $ putMVar connStatus (Right $ RemoteProcessConnection localNode serverProcessId)

141 status <- takeMVar connStatus

149 status <- takeMVar connStatus

142 pure status

150 pure status

143−

151+

144connectPersistentProjectM36 :: PersistenceStrategy ->

152connectPersistentProjectM36 :: PersistenceStrategy ->

145 DiskSync ->

153 DiskSync ->

146 FilePath ->

154 FilePath ->

147− DisconnectedTransaction ->

148 TransactionGraph ->

155 TransactionGraph ->

149 IO (Either ConnectionError Connection)

156 IO (Either ConnectionError Connection)

150−connectPersistentProjectM36 strat sync dbdir freshDiscon freshGraph = do

157+connectPersistentProjectM36 strat sync dbdir freshGraph = do

151 err <- setupDatabaseDir sync dbdir freshGraph

158 err <- setupDatabaseDir sync dbdir freshGraph

152 case err of

159 case err of

153 Just err' -> return $ Left (SetupDatabaseDirectoryError err')

160 Just err' -> return $ Left (SetupDatabaseDirectoryError err')

@@ -156,11 +163,54 @@ connectPersistentProjectM36 strat sync dbdir freshDiscon freshGraph = do

156 case graph of

163 case graph of

157 Left err' -> return $ Left (SetupDatabaseDirectoryError err')

164 Left err' -> return $ Left (SetupDatabaseDirectoryError err')

158 Right graph' -> do

165 Right graph' -> do

159− tvar <- newTVarIO (freshDiscon, graph')

166+ tvarGraph <- newTVarIO graph'

167+ sessions <- STMMap.newIO

160− return $ Right $ InProcessConnection strat tvar

168+ return $ Right $ InProcessConnection strat sessions tvarGraph

169+

170+-- | Create a new session at the transaction UUID and return the session's Id.

171+createSessionAtCommit :: UUID -> Connection -> IO (Either RelationalError SessionId)

172+createSessionAtCommit commitUUID conn@(InProcessConnection _ _ _) = do

173+ newSessionId <- nextRandom

174+ atomically $ do

175+ createSessionAtCommit_ commitUUID newSessionId conn

176+createSessionAtCommit uuid conn@(RemoteProcessConnection _ _) = remoteCall conn (CreateSessionAtCommit uuid)

177+

178+createSessionAtCommit_ :: UUID -> SessionId -> Connection -> STM (Either RelationalError SessionId)

179+createSessionAtCommit_ commitUUID newSessionId (InProcessConnection _ sessions graphTvar) = do

180+ graph <- readTVar graphTvar

181+ case transactionForUUID commitUUID graph of

182+ Left err -> pure (Left err)

183+ Right _ -> do

184+ let freshDiscon = DisconnectedTransaction commitUUID RE.basicDatabaseContext

185+ keyDuplication <- STMMap.lookup newSessionId sessions

186+ case keyDuplication of

187+ Just _ -> pure $ Left (SessionIdInUse newSessionId)

188+ Nothing -> do

189+ STMMap.insert (Session freshDiscon) newSessionId sessions

190+ pure $ Right newSessionId

191+createSessionAtCommit_ _ _ (RemoteProcessConnection _ _) = error "createSessionAtCommit_ called on remote connection"

192+

193+createSessionAtHead :: HeadName -> Connection -> IO (Either RelationalError SessionId)

194+createSessionAtHead headn conn@(InProcessConnection _ _ tvar) = do

195+ newSessionId <- nextRandom

196+ atomically $ do

197+ graph <- readTVar tvar

198+ case transactionForHead headn graph of

199+ Nothing -> pure $ Left (NoSuchHeadNameError headn)

200+ Just trans -> createSessionAtCommit_ (transactionUUID trans) newSessionId conn

201+createSessionAtHead headn conn@(RemoteProcessConnection _ _) = remoteCall conn (CreateSessionAtHead headn)

202+

203+-- | Discards a session, eliminating any uncommitted changes present in the session.

204+closeSession :: SessionId -> Connection -> IO ()

205+closeSession sessionId (InProcessConnection _ sessions _) = do

206+ atomically $ do

207+ STMMap.delete sessionId sessions

208+closeSession sessionId conn@(RemoteProcessConnection _ _) = remoteCall conn (CloseSession sessionId)

161

209

162close :: Connection -> IO ()

210close :: Connection -> IO ()

163−close (InProcessConnection _ _) = pure ()

211+close (InProcessConnection _ sessions _) = atomically $ do

212+ traverse_ (\(k,_) -> STMMap.delete k sessions) (STMMap.stream sessions)

213+ pure ()

164close (RemoteProcessConnection localNode serverProcessId) = do

214close (RemoteProcessConnection localNode serverProcessId) = do

165 runProcessResult localNode $ do

215 runProcessResult localNode $ do

166 call serverProcessId Logout

216 call serverProcessId Logout

@@ -174,114 +224,145 @@ runProcessResult localNode proc = do

174 takeMVar ret

224 takeMVar ret

175

225

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

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

177−remoteCall (InProcessConnection _ _) _ = error "remoteCall called on local connection"

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

178remoteCall (RemoteProcessConnection localNode serverProcessId) arg = runProcessResult localNode $ do

228remoteCall (RemoteProcessConnection localNode serverProcessId) arg = runProcessResult localNode $ do

179 ret <- safeCall serverProcessId arg

229 ret <- safeCall serverProcessId arg

180 case ret of

230 case ret of

181 Left err -> error (show err)

231 Left err -> error (show err)

182 Right ret' -> pure ret'

232 Right ret' -> pure ret'

183

233

234+sessionForSessionId :: SessionId -> Sessions -> STM (Either RelationalError Session)

235+sessionForSessionId sessionId sessions = do

236+ maybeSession <- STMMap.lookup sessionId sessions

237+ pure $ maybe (Left $ NoSuchSession sessionId) Right maybeSession

238+

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

239+executeRelationalExpr :: SessionId -> Connection -> RelationalExpr -> IO (Either RelationalError Relation)

185−executeRelationalExpr (InProcessConnection _ tvar) expr = atomically $ do

240+executeRelationalExpr sessionId (InProcessConnection _ sessions _) expr = atomically $ do

186− ((DisconnectedTransaction _ context), _) <- readTVar tvar

241+ eSession <- sessionForSessionId sessionId sessions

242+ case eSession of

243+ Left err -> pure $ Left err

187− return $ evalState (RE.evalRelationalExpr expr) context

244+ Right (Session (DisconnectedTransaction _ context)) -> pure $ evalState (RE.evalRelationalExpr expr) context

188−executeRelationalExpr conn@(RemoteProcessConnection _ _) relExpr = remoteCall conn (ExecuteRelationalExpr relExpr)

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

189

246

190−executeDatabaseContextExpr :: Connection -> DatabaseExpr -> IO (Maybe RelationalError)

247+executeDatabaseContextExpr :: SessionId -> Connection -> DatabaseExpr -> IO (Maybe RelationalError)

191−executeDatabaseContextExpr (InProcessConnection _ tvar) expr = atomically $ do

248+executeDatabaseContextExpr sessionId (InProcessConnection _ sessions _) expr = atomically $ do

192− ((DisconnectedTransaction parentUUID context), graph) <- readTVar tvar

249+ eSession <- sessionForSessionId sessionId sessions

250+ case eSession of

251+ Left err -> pure $ Just err

193− case runState (RE.evalContextExpr expr) context of

252+ Right session -> case runState (RE.evalContextExpr expr) (sessionContext session) of

194− (Just err,_) -> return $ Just err

253+ (Just err,_) -> return $ Just err

195− (Nothing, context') -> do

254+ (Nothing, context') -> do

196− let newDiscon = DisconnectedTransaction parentUUID context'

255+ let newDiscon = DisconnectedTransaction (sessionParentUUID session) context'

197− writeTVar tvar (newDiscon, graph)

256+ newSession = Session newDiscon

257+ STMMap.insert newSession sessionId sessions

198 return Nothing

258 return Nothing

199−executeDatabaseContextExpr conn@(RemoteProcessConnection _ _) dbExpr = remoteCall conn (ExecuteDatabaseContextExpr dbExpr)

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

200

260

201−executeGraphExpr :: Connection -> TransactionGraphOperator -> IO (Maybe RelationalError)

261+executeGraphExpr :: SessionId -> Connection -> TransactionGraphOperator -> IO (Maybe RelationalError)

202−executeGraphExpr (InProcessConnection strat tvar) graphExpr = do

262+executeGraphExpr sessionId (InProcessConnection strat sessions graphTvar) graphExpr = do

203 freshUUID <- nextRandom

263 freshUUID <- nextRandom

204 manip <- atomically $ do

264 manip <- atomically $ do

205− (discon, graph) <- readTVar tvar

265+ graph <- readTVar graphTvar

266+ eSession <- sessionForSessionId sessionId sessions

267+ case eSession of

268+ Left err -> pure $ Left err

206− case evalGraphOp freshUUID discon graph graphExpr of

269+ Right (Session discon) -> case evalGraphOp freshUUID discon graph graphExpr of

207− Left err -> return $ Left err

270+ Left err -> pure $ Left err

208− Right (discon', graph') -> do

271+ Right (discon', graph') -> do

209− writeTVar tvar (discon', graph')

272+ writeTVar graphTvar graph'

210− return $ Right (discon', graph')

273+ let newSession = Session discon'

274+ STMMap.insert newSession sessionId sessions

275+ pure $ Right graph'

211 case manip of

276 case manip of

212 Left err -> return $ Just err

277 Left err -> return $ Just err

213− Right (_, newGraph) -> do

278+ Right newGraph -> do

214 --update filesystem database, if necessary

279 --update filesystem database, if necessary

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

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

216 processPersistence strat newGraph

281 processPersistence strat newGraph

217 return Nothing

282 return Nothing

218−executeGraphExpr conn@(RemoteProcessConnection _ _) graphExpr = remoteCall conn (ExecuteGraphExpr graphExpr)

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

219

284

220−commit :: Connection -> IO (Maybe RelationalError)

285+commit :: SessionId -> Connection -> IO (Maybe RelationalError)

221−commit conn@(InProcessConnection _ _) = executeGraphExpr conn Commit

286+commit sessionId conn@(InProcessConnection _ _ _) = executeGraphExpr sessionId conn Commit

222−commit conn@(RemoteProcessConnection _ _) = remoteCall conn (ExecuteGraphExpr Commit)

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

223

288

224−rollback :: Connection -> IO (Maybe RelationalError)

289+rollback :: SessionId -> Connection -> IO (Maybe RelationalError)

225−rollback conn@(InProcessConnection _ _) = executeGraphExpr conn Rollback

290+rollback sessionId conn@(InProcessConnection _ _ _) = executeGraphExpr sessionId conn Rollback

226−rollback conn@(RemoteProcessConnection _ _) = remoteCall conn (ExecuteGraphExpr Rollback)

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

227

292

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

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

229processPersistence NoPersistence _ = return ()

294processPersistence NoPersistence _ = return ()

230processPersistence (MinimalPersistence dbdir) graph = transactionGraphPersist NoDiskSync dbdir graph

295processPersistence (MinimalPersistence dbdir) graph = transactionGraphPersist NoDiskSync dbdir graph

231processPersistence (CrashSafePersistence dbdir) graph = transactionGraphPersist FsyncDiskSync dbdir graph

296processPersistence (CrashSafePersistence dbdir) graph = transactionGraphPersist FsyncDiskSync dbdir graph

232

297

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

298+typeForRelationalExpr :: SessionId -> Connection -> RelationalExpr -> IO (Either RelationalError Relation)

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

299+typeForRelationalExpr sessionId conn@(InProcessConnection _ _ _) relExpr = atomically $ typeForRelationalExprSTM sessionId conn relExpr

235−typeForRelationalExpr conn@(RemoteProcessConnection _ _) relExpr = remoteCall conn (ExecuteTypeForRelationalExpr relExpr)

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

236

301

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

302+typeForRelationalExprSTM :: SessionId -> Connection -> RelationalExpr -> STM (Either RelationalError Relation)

238−typeForRelationalExprSTM (InProcessConnection _ tvar) relExpr = do

303+typeForRelationalExprSTM sessionId (InProcessConnection _ sessions _) relExpr = do

239− (DisconnectedTransaction _ context, _) <- readTVar tvar

304+ eSession <- sessionForSessionId sessionId sessions

305+ case eSession of

306+ Left err -> pure $ Left err

240− pure $ evalState (RE.typeForRelationalExpr relExpr) context

307+ Right session -> pure $ evalState (RE.typeForRelationalExpr relExpr) (sessionContext session)

308+

241−typeForRelationalExprSTM _ _ = error "typeForRelationalExprSTM called on non-local connection"

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

242

310

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

311+inclusionDependencies :: SessionId -> Connection -> IO (Either RelationalError (M.Map IncDepName InclusionDependency))

244−inclusionDependencies (InProcessConnection _ tvar) = do

312+inclusionDependencies sessionId (InProcessConnection _ sessions _) = do

245 atomically $ do

313 atomically $ do

246− ((DisconnectedTransaction _ context), _) <- readTVar tvar

314+ eSession <- sessionForSessionId sessionId sessions

315+ case eSession of

316+ Left err -> pure $ Left err

247− pure (B.inclusionDependencies context)

317+ Right session -> pure $ Right (B.inclusionDependencies (sessionContext session))

318+

248−inclusionDependencies conn@(RemoteProcessConnection _ _) = remoteCall conn RetrieveInclusionDependencies

319+inclusionDependencies sessionId conn@(RemoteProcessConnection _ _) = remoteCall conn (RetrieveInclusionDependencies sessionId)

249

320

250

321

251−planForDatabaseContextExpr :: Connection -> DatabaseExpr -> IO (Either RelationalError DatabaseExpr)

322+planForDatabaseContextExpr :: SessionId -> Connection -> DatabaseExpr -> IO (Either RelationalError DatabaseExpr)

252−planForDatabaseContextExpr (InProcessConnection _ tvar) dbExpr = do

323+planForDatabaseContextExpr sessionId (InProcessConnection _ sessions _) dbExpr = do

253 atomically $ do

324 atomically $ do

254− ((DisconnectedTransaction _ context), _) <- readTVar tvar

325+ eSession <- sessionForSessionId sessionId sessions

326+ case eSession of

327+ Left err -> pure $ Left err

255− pure $ evalState (applyStaticDatabaseOptimization dbExpr) context

328+ Right session -> pure $ evalState (applyStaticDatabaseOptimization dbExpr) (sessionContext session)

256−planForDatabaseContextExpr conn@(RemoteProcessConnection _ _) dbExpr = remoteCall conn (RetrievePlanForDatabaseContextExpr dbExpr)

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

257

330

258−transactionGraphAsRelation :: Connection -> IO (Either RelationalError Relation)

331+transactionGraphAsRelation :: SessionId -> Connection -> IO (Either RelationalError Relation)

259−transactionGraphAsRelation (InProcessConnection _ tvar) = do

332+transactionGraphAsRelation sessionId (InProcessConnection _ sessions tvar) = do

260 atomically $ do

333 atomically $ do

334+ eSession <- sessionForSessionId sessionId sessions

335+ case eSession of

336+ Left err -> pure $ Left err

337+ Right (Session discon) -> do

261− (discon, graph) <- readTVar tvar

338+ graph <- readTVar tvar

262− pure $ graphAsRelation discon graph

339+ pure $ graphAsRelation discon graph

340+

263−transactionGraphAsRelation conn@(RemoteProcessConnection _ _) = remoteCall conn RetrieveTransactionGraph

341+transactionGraphAsRelation sessionId conn@(RemoteProcessConnection _ _) = remoteCall conn (RetrieveTransactionGraph sessionId)

264

342

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

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

266−headTransactionUUID :: Connection -> IO (UUID)

344+headTransactionUUID :: SessionId -> Connection -> IO (Maybe UUID)

267−headTransactionUUID (InProcessConnection _ tvar) = do

345+headTransactionUUID sessionId (InProcessConnection _ sessions _) = do

268 atomically $ do

346 atomically $ do

269− (DisconnectedTransaction parentUUID _, _) <- readTVar tvar

347+ eSession <- sessionForSessionId sessionId sessions

270− pure parentUUID

348+ case eSession of

349+ Left _ -> pure Nothing

350+ Right session -> pure $ Just (sessionParentUUID session)

271−headTransactionUUID conn@(RemoteProcessConnection _ _) = remoteCall conn RetrieveHeadTransactionUUID

351+headTransactionUUID sessionId conn@(RemoteProcessConnection _ _) = remoteCall conn (RetrieveHeadTransactionUUID sessionId)

272

352

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

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

274−headName :: Connection -> IO (Maybe HeadName)

354+headName :: SessionId -> Connection -> IO (Maybe HeadName)

275−headName (InProcessConnection _ tvar) = do

355+headName sessionId (InProcessConnection _ sessions graphTvar) = do

276 atomically $ do

356 atomically $ do

277− (DisconnectedTransaction parentUUID _, graph) <- readTVar tvar

357+ graph <- readTVar graphTvar

358+ eSession <- sessionForSessionId sessionId sessions

359+ case eSession of

360+ Left _ -> pure $ Nothing

278− pure $ case transactionForUUID parentUUID graph of

361+ Right session -> pure $ case transactionForUUID (sessionParentUUID session) graph of

279− Left _ -> Nothing

362+ Left _ -> Nothing

280− Right parentTrans -> headNameForTransaction parentTrans graph

363+ Right parentTrans -> headNameForTransaction parentTrans graph

281−headName (RemoteProcessConnection localNode serverProcessId) = do

364+headName sessionId conn@(RemoteProcessConnection _ _) = remoteCall conn (ExecuteHeadName sessionId)

282− runProcessResult localNode $ do

365+

283− ret <- call serverProcessId ExecuteHeadName

284− pure ret

285

366

286

367

287

368

ProjectM36/DatabaseContext.hs+8

@@ -8,3 +8,11 @@ empty = DatabaseContext { inclusionDependencies = M.empty,

8 relationVariables = M.empty,

9 atomFunctions = HS.empty }

11+-- | convert an existing database context into its constituent expression.

12+databaseContextAsDatabaseContextExpr :: DatabaseContext -> DatabaseExpr

13+databaseContextAsDatabaseContextExpr (DatabaseContext incDeps relVars funcs) = MultipleExpr $ incDepsExprs ++ relVarsExprs ++ funcsExprs

14+ where

15+ relVarsExprs = map (\(name, rel) -> Assign name (ExistingRelation rel)) (M.toList relVars)

16+ incDepsExprs :: [DatabaseExpr]

17+ incDepsExprs = map (\(name, dep) -> AddInclusionDependency name dep) (M.toList incDeps)

18+ funcsExprs = [] -- map (\func -> ) (HS.toList funcs) -- there are no databaseExprs to add atom functions yet

ProjectM36/Error.hs+2

@@ -29,6 +29,8 @@ data RelationalError = NoSuchAttributeNamesError (S.Set AttributeName)

29 | NoSuchHeadNameError HeadName

30 | TransactionIsNotAHeadError U.UUID

31 | TransactionGraphCycleError U.UUID

32+ | SessionIdInUse U.UUID

33+ | NoSuchSession U.UUID

32 | NoSuchTupleExprFunctionError AtomFunctionName

34 | NoSuchTupleExprFunctionError AtomFunctionName

33 | AtomTypeMismatchError AtomType AtomType

35 | AtomTypeMismatchError AtomType AtomType

34 | AtomTypeNotSupported AttributeName --used by persistent driver

36 | AtomTypeNotSupported AttributeName --used by persistent driver

ProjectM36/Server/EntryPoints.hs+5−3

@@ -7,7 +7,7 @@ import Control.Distributed.Process.ManagedProcess (ProcessReply)

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

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

9import Data.Map

10−import Data.UUID (UUID)

10+import Data.UUID (UUID, nextRandom)

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

13handleExecuteRelationalExpr conn expr = do

@@ -24,8 +24,10 @@ handleExecuteHeadName conn = do

24 ret <- liftIO $ headName conn

25 reply ret conn

27−handleLogin :: Connection -> Process (ProcessReply Bool Connection)

27+handleLogin :: Connection -> Process (ProcessReply UUID Connection)

28−handleLogin conn = reply True conn

28+handleLogin conn = do

29+ sessionId <- liftIO $ nextRandom

30+ reply sessionId conn

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

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

31handleExecuteGraphExpr conn graphExpr = do

33handleExecuteGraphExpr conn graphExpr = do

ProjectM36/Server/RemoteCallTypes.hs+18−9

@@ -4,26 +4,35 @@ import ProjectM36.Base

4import ProjectM36.TransactionGraph

5import GHC.Generics

6import Data.Binary

7+import Data.UUID

9+type SessionId = UUID

8data Login = Login

11data Login = Login

9 deriving (Binary, Generic)

12 deriving (Binary, Generic)

10data Logout = Logout

13data Logout = Logout

11 deriving (Binary, Generic)

14 deriving (Binary, Generic)

12−data ExecuteRelationalExpr = ExecuteRelationalExpr RelationalExpr

15+data ExecuteRelationalExpr = ExecuteRelationalExpr SessionId RelationalExpr

13 deriving (Binary, Generic)

16 deriving (Binary, Generic)

14−data ExecuteDatabaseContextExpr = ExecuteDatabaseContextExpr DatabaseExpr

17+data ExecuteDatabaseContextExpr = ExecuteDatabaseContextExpr SessionId DatabaseExpr

15 deriving (Binary, Generic)

18 deriving (Binary, Generic)

16−data ExecuteGraphExpr = ExecuteGraphExpr TransactionGraphOperator

19+data ExecuteGraphExpr = ExecuteGraphExpr SessionId TransactionGraphOperator

17 deriving (Binary, Generic)

20 deriving (Binary, Generic)

18−data ExecuteHeadName = ExecuteHeadName

21+data ExecuteHeadName = ExecuteHeadName SessionId

19 deriving (Binary, Generic)

22 deriving (Binary, Generic)

20−data ExecuteTypeForRelationalExpr = ExecuteTypeForRelationalExpr RelationalExpr

23+data ExecuteTypeForRelationalExpr = ExecuteTypeForRelationalExpr SessionId RelationalExpr

21 deriving (Binary, Generic)

24 deriving (Binary, Generic)

22−data RetrieveInclusionDependencies = RetrieveInclusionDependencies

25+data RetrieveInclusionDependencies = RetrieveInclusionDependencies SessionId

23 deriving (Binary, Generic)

26 deriving (Binary, Generic)

24−data RetrievePlanForDatabaseContextExpr = RetrievePlanForDatabaseContextExpr DatabaseExpr

27+data RetrievePlanForDatabaseContextExpr = RetrievePlanForDatabaseContextExpr SessionId DatabaseExpr

25 deriving (Binary, Generic)

28 deriving (Binary, Generic)

26−data RetrieveTransactionGraph = RetrieveTransactionGraph

29+data RetrieveTransactionGraph = RetrieveTransactionGraph SessionId

27 deriving (Binary, Generic)

30 deriving (Binary, Generic)

28−data RetrieveHeadTransactionUUID = RetrieveHeadTransactionUUID

31+data RetrieveHeadTransactionUUID = RetrieveHeadTransactionUUID SessionId

29 deriving (Binary, Generic)

32 deriving (Binary, Generic)

33+data CreateSessionAtCommit = CreateSessionAtCommit UUID

34+ deriving (Binary, Generic)

35+data CreateSessionAtHead = CreateSessionAtHead HeadName

36+ deriving (Binary, Generic)

37+data CloseSession = CloseSession SessionId

38+ deriving (Binary, Generic)

ProjectM36/Session.hsnew file+13

@@ -0,0 +1,13 @@

1+module ProjectM36.Session where

2+import ProjectM36.Base

3+import Data.UUID

5+--the persistence of a session is as long as the life of the database (not serialized to disk)

6+-- sessions are not associated with connections and have separate lifetimes

7+data Session = Session DisconnectedTransaction

9+sessionContext :: Session -> DatabaseContext

10+sessionContext (Session (DisconnectedTransaction _ context)) = context

11+

12+sessionParentUUID :: Session -> UUID

13+sessionParentUUID (Session (DisconnectedTransaction parentUUID _)) = parentUUID

benchmark/bigrel.hs+2−2

@@ -56,8 +56,8 @@ matrixRun (BigrelArgs attributeCount tupleCount tutd) = do

56 let setx = Assign "x" (ExistingRelation (force rel))

57 context = execState (evalContextExpr setx) dateExamples

58 interpreted = interpretDatabaseExpr context tutd

59− plan = interpretRODatabaseContextOp context $ ":showplan " ++ tutd

59+ --plan = interpretRODatabaseContextOp context $ ":showplan " ++ tutd

60− displayOpResult plan

60+ --displayOpResult plan

61 case interpreted of

62 Right context' -> TIO.putStrLn $ relationAsHTML ((relationVariables context') M.! "x")

63 Left err -> hPutStrLn stderr (show err)

project-m36.cabal+13−2

@@ -63,6 +63,8 @@ Library

63 ,network-transport-tcp

64 ,network-transport

65 ,distributed-process

66+ ,stm-containers

67+ ,list-t

66 Exposed-Modules: ProjectM36.Error,

68 Exposed-Modules: ProjectM36.Error,

67 ProjectM36.Transaction,

69 ProjectM36.Transaction,

68 ProjectM36.TransactionGraph,

70 ProjectM36.TransactionGraph,

@@ -195,6 +197,7 @@ Executable bigrel

195 main-is: benchmark/bigrel.hs

197 main-is: benchmark/bigrel.hs

196 GHC-Options: -Wall -threaded -rtsopts

198 GHC-Options: -Wall -threaded -rtsopts

197 GHC-Prof-Options: -fprof-auto -rtsopts -threaded -Wall

199 GHC-Prof-Options: -fprof-auto -rtsopts -threaded -Wall

200+ C-sources: ProjectM36/DirectoryFsync.c

198

201

199Test-Suite test-tutoriald

202Test-Suite test-tutoriald

200 Default-Language: Haskell2010

203 Default-Language: Haskell2010

@@ -270,8 +273,16 @@ Test-Suite test-server

270 GHC-Options: -Wall

273 GHC-Options: -Wall

271 C-sources: ProjectM36/DirectoryFsync.c

274 C-sources: ProjectM36/DirectoryFsync.c

272

275

273−Executable SimpleClient

276+Executable Example-SimpleClient

274 Default-Language: Haskell2010

277 Default-Language: Haskell2010

275 Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, network-transport-tcp, distributed-process, distributed-process-extras, distributed-process-client-server, uuid, stm, deepseq, deepseq-generics, binary, unix, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, parsec, text, base64-bytestring, data-interval, filepath, transformers

278 Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, network-transport-tcp, distributed-process, distributed-process-extras, distributed-process-client-server, uuid, stm, deepseq, deepseq-generics, binary, unix, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, parsec, text, base64-bytestring, data-interval, filepath, transformers

276 Main-Is: examples/SimpleClient.hs

279 Main-Is: examples/SimpleClient.hs

277− GHC-Options: -Wall

280+ GHC-Options: -Wall

281+ C-sources: ProjectM36/DirectoryFsync.c

282+

283+Executable Example-PersistClient

284+ Default-Language: Haskell2010

285+ Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, network-transport-tcp, distributed-process, distributed-process-extras, distributed-process-client-server, uuid, stm, deepseq, deepseq-generics, binary, unix, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, parsec, text, base64-bytestring, data-interval, filepath, transformers

286+ Main-Is: examples/PersistClient.hs

287+ GHC-Options: -Wall

288+ C-sources: ProjectM36/DirectoryFsync.c

test/Daemon/Main.hs → test/Server/Main.hsrenamed+5−5

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

1{-# LANGUAGE OverloadedStrings #-}

2{-

3−test client/daemon interaction

3+test client/server interaction

4-}

5import Test.HUnit

6import ProjectM36.Client

7−import ProjectM36.Daemon

7+import ProjectM36.Server

8−import ProjectM36.Daemon.Config

8+import ProjectM36.Server.Config

9import ProjectM36.Relation

10import ProjectM36.Atom

11import ProjectM36.TupleSet

@@ -42,10 +42,10 @@ testConnection port = do

42 let connInfo = RemoteProcessConnectionInfo testDatabaseName (createNodeId "127.0.0.1" port)

43 connectProjectM36 connInfo

45−-- | A version of 'launchDaemon' which returns the port on which the server is listening on a secondary thread

45+-- | A version of 'launchServer' which returns the port on which the server is listening on a secondary thread

46launchTestServer :: IO (Port)

47launchTestServer = do

48− let config = defaultDaemonConfig { databaseName = testDatabaseName }

48+ let config = defaultServerConfig { databaseName = testDatabaseName }

49 portVar <- newEmptyMVar

50 _ <- forkIO $ launchServer config (Just portVar) >> pure ()

51 takeMVar portVar