@@ -1,27 +1,45 @@
1−{-# LANGUAGE OverloadedStrings #-}
21--module ProjectM36.Server.WebSocket where
32-- while the tutd client performs TutorialD parsing on the client, the websocket server will pass tutd to be parsed and executed on the server- otherwise I have to pull in ghcjs as a dependency to allow client-side parsing- that's not appealing because then the frontend is not language-agnostic, but this could change in the future, perhaps by sending different messages over the websocket
43-- ideally, the wire protocol should not be exposed to a straight string-based API ala SQL, so we could make perhaps a javascript DSL which compiles to the necessary JSON- anaylyze tradeoffs
4+
5+-- launch the project-m36-server
6+-- proxy all connections to it through ProjectM36.Client
57import Control.Monad (forever)
68import qualified Data.Text as T
79import qualified Network.WebSockets as WS
810import ProjectM36.Server.RemoteCallTypes.Json ()
911import ProjectM36.Client.Json ()
10−import ProjectM36.Base
1112import Data.Aeson
1213import TutorialD.Interpreter
1314import TutorialD.Interpreter.Base
1415import ProjectM36.Client
16+import ProjectM36.Server
17+import ProjectM36.Server.ParseArgs
18+import ProjectM36.Server.Config
19+import Control.Concurrent
20+import Control.Exception
21+
22+-- | Called when the project-m36-server exits.
23+failureHandler :: Either SomeException Bool -> IO ()
24+failureHandler = error "project-m36-server exited unexpectedly"
1525
1626main :: IO ()
1727main = do
28+ -- launch normal project-m36-server
29+ portMVar <- newEmptyMVar
30+ serverConfig <- parseConfig
31+ let serverHost = bindHost serverConfig
32+ databasename = databaseName serverConfig
33+ _ <- forkFinally (launchServer serverConfig (Just portMVar)) failureHandler
34+ --wait for server to be listening
35+ serverPort <- takeMVar portMVar
1836 --this built-in server is apparently not meant for production use, but it's easier to test than starting up the wai or snap interfaces
19− WS.runServer "0.0.0.0" 8888 application
37+ WS.runServer "0.0.0.0" 8888 (websocketProxyServer databasename serverPort serverHost)
2038
21−application :: WS.ServerApp
22−application pending = do
39+websocketProxyServer :: DatabaseName -> Port -> Hostname -> WS.ServerApp
40+websocketProxyServer dbname port host pending = do
2341 conn <- WS.acceptRequest pending
24− (sessionId, dbconn) <- createConnection conn
42+ (sessionId, dbconn) <- createConnection conn dbname port host
2543 forever $ do
2644 msg <- (WS.receiveData conn) :: IO T.Text
2745 let tutdprefix = "executetutd:"
@@ -29,10 +47,10 @@ application pending = do
2947 _ | tutdprefix `T.isPrefixOf` msg -> do
3048 let tutdString = T.drop (T.length tutdprefix) msg
3149 case parseTutorialD (T.unpack tutdString) of
32− Left err -> handleOpResult conn (DisplayErrorResult ("parse error: " `T.append` T.pack (show err)))
50+ Left err -> handleOpResult conn dbconn (DisplayErrorResult ("parse error: " `T.append` T.pack (show err)))
3351 Right parsed -> do
3452 result <- evalTutorialD sessionId dbconn parsed
35− handleOpResult conn result
53+ handleOpResult conn dbconn result
3654 _ -> WS.sendTextData conn ("message not expected" :: T.Text)
3755 return ()
3856
@@ -42,21 +60,21 @@ notificationCallback conn notifName evaldNotif = WS.sendTextData conn (encode (o
4260 ]))
4361
4462--this creates a new database for each connection- perhaps not what we want (?)
45−createConnection :: WS.Connection -> IO (SessionId, Connection)
46−createConnection wsconn = do
47− eConn <- connectProjectM36 (InProcessConnectionInfo NoPersistence (notificationCallback wsconn))
63+createConnection :: WS.Connection -> DatabaseName -> Port -> Hostname -> IO (SessionId, Connection)
64+createConnection wsconn dbname port host = do
65+ eConn <- connectProjectM36 (RemoteProcessConnectionInfo dbname (createNodeId host port) (notificationCallback wsconn))
4866 case eConn of
49− Left err -> error $ "failed to create database" ++ show err
67+ Left err -> error $ "failed to connect to database" ++ show err
5068 Right conn -> do
5169 eSessionId <- createSessionAtHead "master" conn
5270 case eSessionId of
5371 Left err -> error $ "failed to create connection on master branch" ++ show err
5472 Right sessionId -> pure (sessionId, conn)
5573
56−handleOpResult :: WS.Connection -> TutorialDOperatorResult -> IO ()
57−handleOpResult conn QuitResult = WS.sendClose conn ("close" :: T.Text)
58−handleOpResult conn (DisplayResult out) = WS.sendTextData conn (encode (object ["display" .= out]))
59−handleOpResult _ (DisplayIOResult ioout) = ioout
60−handleOpResult conn (DisplayErrorResult err) = WS.sendTextData conn (encode (object ["displayerror" .= err]))
61−handleOpResult conn QuietSuccessResult = WS.sendTextData conn (encode (object ["acknowledged" .= True]))
62−handleOpResult conn (DisplayRelationResult rel) = WS.sendTextData conn (encode (object ["displayrelation" .= rel]))
74+handleOpResult :: WS.Connection -> Connection -> TutorialDOperatorResult -> IO ()
75+handleOpResult conn db QuitResult = WS.sendClose conn ("close" :: T.Text) >> close db
76+handleOpResult conn _ (DisplayResult out) = WS.sendTextData conn (encode (object ["display" .= out]))
77+handleOpResult _ _ (DisplayIOResult ioout) = ioout
78+handleOpResult conn _ (DisplayErrorResult err) = WS.sendTextData conn (encode (object ["displayerror" .= err]))
79+handleOpResult conn _ QuietSuccessResult = WS.sendTextData conn (encode (object ["acknowledged" .= True]))
80+handleOpResult conn _ (DisplayRelationResult rel) = WS.sendTextData conn (encode (object ["displayrelation" .= rel]))