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

git.iko.soy/project-m36

tutd propagates notifications to stderr

commit69e34612a60ef987254ad7ca90e2b9fb0ed394ee authorAgentM <agentm@themactionfaction.com> dateMon 25 Jan 2016, 14:29 (11 years ago) parent0bf7786

4 files changed+51−25

compare with master

unifiedsplit

ProjectM36/Client.hs+38−20 ProjectM36/Server.hs+6−2 TutorialD/Interpreter.hs+4 TutorialD/tutd.hs+3−3

ProjectM36/Client.hs+38−20

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

4141 Atom(..),

4242 Session,

4343 SessionId,

44+ NotificationCallback,

4445 AtomType(..)) where

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

4647import qualified ProjectM36.Base as B

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

7778import ListT

7879import Data.Binary (Binary)

7980import GHC.Generics (Generic)

81+import System.IO (stderr, hPutStrLn)

8082--import Debug.Trace

8183

8284type Hostname = String

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

8587

8688type DatabaseName = String

8789

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+

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

89−data ConnectionInfo = InProcessConnectionInfo PersistenceStrategy |

90− RemoteProcessConnectionInfo DatabaseName NodeId

98+data ConnectionInfo = InProcessConnectionInfo PersistenceStrategy NotificationCallback |

99+ RemoteProcessConnectionInfo DatabaseName NodeId NotificationCallback

91100

92101type EvaluatedNotifications = M.Map NotificationName EvaluatedNotification

93102

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

115124defaultHeadName = "master"

116125

117126defaultRemoteConnectionInfo :: ConnectionInfo

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

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

119128

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

121130type ClientNodes = STMSet.Set ProcessId

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

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

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

143152

144−notificationListener :: Process ()

145−notificationListener = do

153+notificationListener :: NotificationCallback -> Process ()

154+notificationListener callback = do

146155 pid <- getSelfPid

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

148157 _ <- forever $ do

149158 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+ )

151163 ]

152164 say "LISTENER THREAD EXIT"

153165 pure ()

154166

155−startNotificationListener :: IO (ProcessId)

156−startNotificationListener = do

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

168+startNotificationListener callback = do

157169 eLocalNode <- commonLocalNode

158170 case eLocalNode of

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

160− Right localNode -> forkProcess localNode notificationListener

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

161173

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

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

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

165−connectProjectM36 (InProcessConnectionInfo strat) = do

177+connectProjectM36 (InProcessConnectionInfo strat notificationCallback) = do

166178 freshUUID <- nextRandom

167179 let bootstrapContext = RE.basicDatabaseContext

168180 freshGraph = bootstrapTransactionGraph freshUUID bootstrapContext

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

172184 graphTvar <- newTVarIO freshGraph

173185 clientNodes <- STMSet.newIO

174186 sessions <- STMMap.newIO

175− --notificationPid <- startNotificationListener

176− return $ Right $ InProcessConnection strat clientNodes sessions graphTvar

177− MinimalPersistence dbdir -> connectPersistentProjectM36 strat NoDiskSync dbdir freshGraph

178− CrashSafePersistence dbdir -> connectPersistentProjectM36 strat FsyncDiskSync dbdir freshGraph

187+ notificationPid <- startNotificationListener notificationCallback

188+ let conn = InProcessConnection strat clientNodes sessions graphTvar

189+ addClientNode conn notificationPid

190+ pure (Right conn)

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

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

179193

180−connectProjectM36 (RemoteProcessConnectionInfo databaseName serverNodeId) = do

194+connectProjectM36 (RemoteProcessConnectionInfo databaseName serverNodeId notificationCallback) = do

181195 connStatus <- newEmptyMVar

182196 eLocalNode <- commonLocalNode

183− notificationListenerPid <- startNotificationListener

197+ notificationListenerPid <- startNotificationListener notificationCallback

184198 let dbName = remoteDBLookupName databaseName

185199 putStrLn $ show serverNodeId ++ " " ++ dbName

186200 case eLocalNode of

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

202216connectPersistentProjectM36 :: PersistenceStrategy ->

203217 DiskSync ->

204218 FilePath ->

205− TransactionGraph ->

219+ TransactionGraph ->

220+ NotificationCallback ->

206221 IO (Either ConnectionError Connection)

207−connectPersistentProjectM36 strat sync dbdir freshGraph = do

222+connectPersistentProjectM36 strat sync dbdir freshGraph notificationCallback = do

208223 err <- setupDatabaseDir sync dbdir freshGraph

209224 case err of

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

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

216231 tvarGraph <- newTVarIO graph'

217232 sessions <- STMMap.newIO

218233 clientNodes <- STMSet.newIO

219− return $ Right $ InProcessConnection strat clientNodes sessions tvarGraph

220−

234+ let conn = InProcessConnection strat clientNodes sessions tvarGraph

235+ notificationPid <- startNotificationListener notificationCallback

236+ addClientNode conn notificationPid

237+ pure (Right conn)

238+

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

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

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

ProjectM36/Server.hs+6−2

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

5454 let dbname' = remoteDBLookupName dbname

5555 register dbname' self

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

5862-- | 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.

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

6064launchServer daemonConfig mPortMVar = do

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

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

6266 case econn of

6367 Left err -> do

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

TutorialD/Interpreter.hs+4

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

2525import System.Directory (getHomeDirectory)

2626import qualified Data.Text as T

2727import Data.Maybe (fromMaybe)

28+import System.IO (hPutStrLn, stderr)

2829

2930{-

3031context 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

117118data InterpreterConfig = LocalInterpreterConfig PersistenceStrategy HeadName|

118119 RemoteInterpreterConfig C.NodeId C.DatabaseName HeadName

119120

121+outputNotificationCallback :: C.NotificationCallback

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

123+

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

121125reprLoop config sessionId conn = do

122126 homeDirectory <- getHomeDirectory

TutorialD/tutd.hs+3−3

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

4949opts = info parseArgs idm

5050

5151connectionInfoForConfig :: InterpreterConfig -> ConnectionInfo

52−connectionInfoForConfig (LocalInterpreterConfig pStrategy _) = InProcessConnectionInfo pStrategy

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

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

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

5454

5555headNameForConfig :: InterpreterConfig -> HeadName

5656headNameForConfig (LocalInterpreterConfig _ headn) = headn

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

5858

5959errDie :: String -> IO ()

6060errDie err = hPutStrLn stderr err >> exitFailure

61−

61+

6262main :: IO ()

6363main = do

6464 interpreterConfig <- execParser opts