69e3461 · project-m36 · git.iko.soy

git.iko.soy/project-m36

on master help sign in

tutd propagates notifications to stderr

69e3461AgentM11 years ago

ProjectM36/Client.hs+38−20

compare with master

unifiedsplit

@@ -41,6 +41,7 @@ module ProjectM36.Client

41 Atom(..),

42 Session,

43 SessionId,

44+ NotificationCallback,

44 AtomType(..)) where

45 AtomType(..)) where

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

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

46import qualified ProjectM36.Base as B

47import qualified ProjectM36.Base as B

@@ -77,6 +78,7 @@ import ProjectM36.Sessions

77import ListT

78import ListT

78import Data.Binary (Binary)

79import Data.Binary (Binary)

79import GHC.Generics (Generic)

80import GHC.Generics (Generic)

81+import System.IO (stderr, hPutStrLn)

80--import Debug.Trace

82--import Debug.Trace

82type Hostname = String

84type Hostname = String

@@ -85,9 +87,16 @@ type Port = Word16

86type DatabaseName = String

88type DatabaseName = String

90+-- | The type for notifications callbacks in the client. When a registered notification fires due to a changed relational expression evaluation, the server propagates the notifications to the clients in the form of the callback.

91+type NotificationCallback = NotificationName -> EvaluatedNotification -> IO ()

92+

93+-- | The empty notification callback ignores all callbacks.

94+emptyNotificationCallback :: NotificationCallback

95+emptyNotificationCallback _ _ = pure ()

96+

88-- | Construct a 'ConnectionInfo' to describe how to make the 'Connection'.

97-- | Construct a 'ConnectionInfo' to describe how to make the 'Connection'.

89−data ConnectionInfo = InProcessConnectionInfo PersistenceStrategy |

98+data ConnectionInfo = InProcessConnectionInfo PersistenceStrategy NotificationCallback |

90− RemoteProcessConnectionInfo DatabaseName NodeId

99+ RemoteProcessConnectionInfo DatabaseName NodeId NotificationCallback

100

92type EvaluatedNotifications = M.Map NotificationName EvaluatedNotification

101type EvaluatedNotifications = M.Map NotificationName EvaluatedNotification

102

@@ -115,7 +124,7 @@ defaultHeadName :: HeadName

115defaultHeadName = "master"

124defaultHeadName = "master"

116

125

117defaultRemoteConnectionInfo :: ConnectionInfo

126defaultRemoteConnectionInfo :: ConnectionInfo

118−defaultRemoteConnectionInfo = RemoteProcessConnectionInfo defaultDatabaseName (createNodeId "127.0.0.1" defaultServerPort)

127+defaultRemoteConnectionInfo = RemoteProcessConnectionInfo defaultDatabaseName (createNodeId "127.0.0.1" defaultServerPort) emptyNotificationCallback

119

128

120-- | The 'Connection' represents either local or remote access to a database. All operations flow through the connection.

129-- | The 'Connection' represents either local or remote access to a database. All operations flow through the connection.

121type ClientNodes = STMSet.Set ProcessId

130type ClientNodes = STMSet.Set ProcessId

@@ -141,28 +150,31 @@ commonLocalNode = do

141 Left err -> pure (Left $ IOExceptionError err)

150 Left err -> pure (Left $ IOExceptionError err)

142 Right localTransport -> newLocalNode localTransport initRemoteTable >>= pure . Right

151 Right localTransport -> newLocalNode localTransport initRemoteTable >>= pure . Right

143

152

144−notificationListener :: Process ()

153+notificationListener :: NotificationCallback -> Process ()

145−notificationListener = do

154+notificationListener callback = do

146 pid <- getSelfPid

155 pid <- getSelfPid

147 liftIO $ putStrLn $ "LISTENER THREAD START " ++ show pid

156 liftIO $ putStrLn $ "LISTENER THREAD START " ++ show pid

148 _ <- forever $ do

157 _ <- forever $ do

149 receiveWait [

158 receiveWait [

150− match (\(NotificationMessage eNots) -> say $ "NOTIFICATION: " ++ show eNots)

159+ match (\(NotificationMessage eNots) -> do

160+ --say $ "NOTIFICATION: " ++ show eNots

161+ liftIO $ mapM_ (uncurry callback) (M.toList eNots)

162+ )

151 ]

163 ]

152 say "LISTENER THREAD EXIT"

164 say "LISTENER THREAD EXIT"

153 pure ()

165 pure ()

154

166

155−startNotificationListener :: IO (ProcessId)

167+startNotificationListener :: NotificationCallback -> IO (ProcessId)

156−startNotificationListener = do

168+startNotificationListener callback = do

157 eLocalNode <- commonLocalNode

169 eLocalNode <- commonLocalNode

158 case eLocalNode of

170 case eLocalNode of

159 Left err -> error ("Failed to start local notification listener: " ++ show err)

171 Left err -> error ("Failed to start local notification listener: " ++ show err)

160− Right localNode -> forkProcess localNode notificationListener

172+ Right localNode -> forkProcess localNode (notificationListener callback)

161

173

162-- | To create a 'Connection' to a remote or local database, create a connectionInfo and call 'connectProjectM36'.

174-- | To create a 'Connection' to a remote or local database, create a connectionInfo and call 'connectProjectM36'.

163connectProjectM36 :: ConnectionInfo -> IO (Either ConnectionError Connection)

175connectProjectM36 :: ConnectionInfo -> IO (Either ConnectionError Connection)

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

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

165−connectProjectM36 (InProcessConnectionInfo strat) = do

177+connectProjectM36 (InProcessConnectionInfo strat notificationCallback) = do

166 freshUUID <- nextRandom

178 freshUUID <- nextRandom

167 let bootstrapContext = RE.basicDatabaseContext

179 let bootstrapContext = RE.basicDatabaseContext

168 freshGraph = bootstrapTransactionGraph freshUUID bootstrapContext

180 freshGraph = bootstrapTransactionGraph freshUUID bootstrapContext

@@ -172,15 +184,17 @@ connectProjectM36 (InProcessConnectionInfo strat) = do

172 graphTvar <- newTVarIO freshGraph

184 graphTvar <- newTVarIO freshGraph

173 clientNodes <- STMSet.newIO

185 clientNodes <- STMSet.newIO

174 sessions <- STMMap.newIO

186 sessions <- STMMap.newIO

175− --notificationPid <- startNotificationListener

187+ notificationPid <- startNotificationListener notificationCallback

176− return $ Right $ InProcessConnection strat clientNodes sessions graphTvar

188+ let conn = InProcessConnection strat clientNodes sessions graphTvar

189+ addClientNode conn notificationPid

190+ pure (Right conn)

177− MinimalPersistence dbdir -> connectPersistentProjectM36 strat NoDiskSync dbdir freshGraph

191+ MinimalPersistence dbdir -> connectPersistentProjectM36 strat NoDiskSync dbdir freshGraph notificationCallback

178− CrashSafePersistence dbdir -> connectPersistentProjectM36 strat FsyncDiskSync dbdir freshGraph

192+ CrashSafePersistence dbdir -> connectPersistentProjectM36 strat FsyncDiskSync dbdir freshGraph notificationCallback

179

193

180−connectProjectM36 (RemoteProcessConnectionInfo databaseName serverNodeId) = do

194+connectProjectM36 (RemoteProcessConnectionInfo databaseName serverNodeId notificationCallback) = do

181 connStatus <- newEmptyMVar

195 connStatus <- newEmptyMVar

182 eLocalNode <- commonLocalNode

196 eLocalNode <- commonLocalNode

183− notificationListenerPid <- startNotificationListener

197+ notificationListenerPid <- startNotificationListener notificationCallback

184 let dbName = remoteDBLookupName databaseName

198 let dbName = remoteDBLookupName databaseName

185 putStrLn $ show serverNodeId ++ " " ++ dbName

199 putStrLn $ show serverNodeId ++ " " ++ dbName

186 case eLocalNode of

200 case eLocalNode of

@@ -202,9 +216,10 @@ connectProjectM36 (RemoteProcessConnectionInfo databaseName serverNodeId) = do

202connectPersistentProjectM36 :: PersistenceStrategy ->

216connectPersistentProjectM36 :: PersistenceStrategy ->

203 DiskSync ->

217 DiskSync ->

204 FilePath ->

218 FilePath ->

205− TransactionGraph ->

219+ TransactionGraph ->

220+ NotificationCallback ->

206 IO (Either ConnectionError Connection)

221 IO (Either ConnectionError Connection)

207−connectPersistentProjectM36 strat sync dbdir freshGraph = do

222+connectPersistentProjectM36 strat sync dbdir freshGraph notificationCallback = do

208 err <- setupDatabaseDir sync dbdir freshGraph

223 err <- setupDatabaseDir sync dbdir freshGraph

209 case err of

224 case err of

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

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

@@ -216,8 +231,11 @@ connectPersistentProjectM36 strat sync dbdir freshGraph = do

216 tvarGraph <- newTVarIO graph'

231 tvarGraph <- newTVarIO graph'

217 sessions <- STMMap.newIO

232 sessions <- STMMap.newIO

218 clientNodes <- STMSet.newIO

233 clientNodes <- STMSet.newIO

219− return $ Right $ InProcessConnection strat clientNodes sessions tvarGraph

234+ let conn = InProcessConnection strat clientNodes sessions tvarGraph

220−

235+ notificationPid <- startNotificationListener notificationCallback

236+ addClientNode conn notificationPid

237+ pure (Right conn)

238+

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

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

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

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

223createSessionAtCommit commitUUID conn@(InProcessConnection _ _ _ _) = do

241createSessionAtCommit commitUUID conn@(InProcessConnection _ _ _ _) = do

ProjectM36/Server.hs+6−2

@@ -54,11 +54,15 @@ registerDB dbname = do

54 let dbname' = remoteDBLookupName dbname

55 register dbname' self

56 liftIO $ putStrLn $ "registered " ++ (show self) ++ " " ++ dbname'

57−

57+

58+-- | A notification callback which logs the notification to stderr and does nothing else.

59+loggingNotificationCallback :: NotificationCallback

60+loggingNotificationCallback notName evaldNot = hPutStrLn stderr $ "Notification received \"" ++ show notName ++ "\": " ++ show evaldNot

61+

58-- | A synchronous function to start the project-m36 daemon given an appropriate 'ServerConfig'. Note that this function only returns if the server exits. Returns False if the daemon exited due to an error. If the second argument is not Nothing, the port is put after the server is ready to service the port.

62-- | A synchronous function to start the project-m36 daemon given an appropriate 'ServerConfig'. Note that this function only returns if the server exits. Returns False if the daemon exited due to an error. If the second argument is not Nothing, the port is put after the server is ready to service the port.

59launchServer :: ServerConfig -> Maybe (MVar Port) -> IO (Bool)

63launchServer :: ServerConfig -> Maybe (MVar Port) -> IO (Bool)

60launchServer daemonConfig mPortMVar = do

64launchServer daemonConfig mPortMVar = do

61− econn <- connectProjectM36 (InProcessConnectionInfo (persistenceStrategy daemonConfig))

65+ econn <- connectProjectM36 (InProcessConnectionInfo (persistenceStrategy daemonConfig) loggingNotificationCallback)

62 case econn of

66 case econn of

63 Left err -> do

67 Left err -> do

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

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

TutorialD/Interpreter.hs+4

@@ -25,6 +25,7 @@ import System.Console.Haskeline

25import System.Directory (getHomeDirectory)

26import qualified Data.Text as T

27import Data.Maybe (fromMaybe)

28+import System.IO (hPutStrLn, stderr)

29{-

30{-

30context ops are read-only operations which only operate on the database context (relvars and constraints)

31context ops are read-only operations which only operate on the database context (relvars and constraints)

@@ -117,6 +118,9 @@ evalTutorialD sessionId conn expr = case expr of

117data InterpreterConfig = LocalInterpreterConfig PersistenceStrategy HeadName|

118data InterpreterConfig = LocalInterpreterConfig PersistenceStrategy HeadName|

118 RemoteInterpreterConfig C.NodeId C.DatabaseName HeadName

119 RemoteInterpreterConfig C.NodeId C.DatabaseName HeadName

119

120

121+outputNotificationCallback :: C.NotificationCallback

122+outputNotificationCallback notName evaldNot = hPutStrLn stderr $ "Notification received \"" ++ show notName ++ "\": " ++ show evaldNot

123+

120reprLoop :: InterpreterConfig -> C.SessionId -> C.Connection -> IO ()

124reprLoop :: InterpreterConfig -> C.SessionId -> C.Connection -> IO ()

121reprLoop config sessionId conn = do

125reprLoop config sessionId conn = do

122 homeDirectory <- getHomeDirectory

126 homeDirectory <- getHomeDirectory

TutorialD/tutd.hs+3−3

@@ -49,8 +49,8 @@ opts :: ParserInfo InterpreterConfig

49opts = info parseArgs idm

51connectionInfoForConfig :: InterpreterConfig -> ConnectionInfo

52−connectionInfoForConfig (LocalInterpreterConfig pStrategy _) = InProcessConnectionInfo pStrategy

52+connectionInfoForConfig (LocalInterpreterConfig pStrategy _) = InProcessConnectionInfo pStrategy outputNotificationCallback

53−connectionInfoForConfig (RemoteInterpreterConfig remoteNodeId remoteDBName _) = RemoteProcessConnectionInfo remoteDBName remoteNodeId

53+connectionInfoForConfig (RemoteInterpreterConfig remoteNodeId remoteDBName _) = RemoteProcessConnectionInfo remoteDBName remoteNodeId outputNotificationCallback

55headNameForConfig :: InterpreterConfig -> HeadName

56headNameForConfig (LocalInterpreterConfig _ headn) = headn

@@ -58,7 +58,7 @@ headNameForConfig (RemoteInterpreterConfig _ _ headn) = headn

59errDie :: String -> IO ()

60errDie err = hPutStrLn stderr err >> exitFailure

61−

61+

62main :: IO ()

63main = do

64 interpreterConfig <- execParser opts