@@ -1,89 +0,0 @@
1−--module ProjectM36.Server.WebSocket where
2−-- 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
3−-- 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
7−import Control.Monad (forever)
8−import qualified Data.Text as T
9−import qualified Network.WebSockets as WS
10−import ProjectM36.Server.RemoteCallTypes.Json ()
11−import ProjectM36.Client.Json ()
12−import Data.Aeson
13−import TutorialD.Interpreter
14−import TutorialD.Interpreter.Base
15−import 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"
25−
26−main :: IO ()
27−main = do
28− -- launch normal project-m36-server
29− portMVar <- newEmptyMVar
30− serverConfig <- parseConfig
31− let serverHost = bindHost serverConfig
32− _ <- forkFinally (launchServer serverConfig (Just portMVar)) failureHandler
33− --wait for server to be listening
34− serverPort <- takeMVar portMVar
35− --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
36− WS.runServer "0.0.0.0" 8888 (websocketProxyServer serverPort serverHost)
37−
38−websocketProxyServer :: Port -> Hostname -> WS.ServerApp
39−websocketProxyServer port host pending = do
40− conn <- WS.acceptRequest pending
41− let unexpectedMsg = WS.sendTextData conn ("messagenotexpected" :: T.Text)
42− --phase 1- accept database name for connection
43− dbmsg <- (WS.receiveData conn) :: IO T.Text
44− let connectdbmsg = "connectdb:"
45− if not (connectdbmsg `T.isPrefixOf` dbmsg) then unexpectedMsg >> WS.sendClose conn ("" :: T.Text)
46− else do
47− let dbname = T.unpack $ T.drop (T.length connectdbmsg) dbmsg
48− eDbconn <- createConnection conn dbname port host
49− case eDbconn of
50− Left err -> sendError conn err
51− Right dbconn -> do
52− eSessionId <- createSessionAtHead "master" dbconn
53− case eSessionId of
54− Left err -> sendError conn err
55− Right sessionId -> do
56− --phase 2- accept tutoriald commands
57− _ <- forever $ do
58− msg <- (WS.receiveData conn) :: IO T.Text
59− let tutdprefix = "executetutd:"
60− case msg of
61− _ | tutdprefix `T.isPrefixOf` msg -> do
62− let tutdString = T.drop (T.length tutdprefix) msg
63− case parseTutorialD (T.unpack tutdString) of
64− Left err -> handleOpResult conn dbconn (DisplayErrorResult ("parse error: " `T.append` T.pack (show err)))
65− Right parsed -> do
66− result <- evalTutorialD sessionId dbconn SafeEvaluation parsed
67− handleOpResult conn dbconn result
68− _ -> unexpectedMsg
69− pure ()
70−
71−notificationCallback :: WS.Connection -> NotificationCallback
72−notificationCallback conn notifName evaldNotif = WS.sendTextData conn (encode (object ["notificationname" .= notifName,
73− "evaldnotification" .= evaldNotif
74− ]))
75−
76−--this creates a new database for each connection- perhaps not what we want (?)
77−createConnection :: WS.Connection -> DatabaseName -> Port -> Hostname -> IO (Either ConnectionError Connection)
78−createConnection wsconn dbname port host = connectProjectM36 (RemoteProcessConnectionInfo dbname (createNodeId host port) (notificationCallback wsconn))
79−
80−sendError :: (ToJSON a) => WS.Connection -> a -> IO ()
81−sendError conn err = WS.sendTextData conn (encode (object ["displayerror" .= err]))
82−
83−handleOpResult :: WS.Connection -> Connection -> TutorialDOperatorResult -> IO ()
84−handleOpResult conn db QuitResult = WS.sendClose conn ("close" :: T.Text) >> close db
85−handleOpResult conn _ (DisplayResult out) = WS.sendTextData conn (encode (object ["display" .= out]))
86−handleOpResult _ _ (DisplayIOResult ioout) = ioout
87−handleOpResult conn _ (DisplayErrorResult err) = WS.sendTextData conn (encode (object ["displayerror" .= err]))
88−handleOpResult conn _ QuietSuccessResult = WS.sendTextData conn (encode (object ["acknowledged" .= True]))
89−handleOpResult conn _ (DisplayRelationResult rel) = WS.sendTextData conn (encode (object ["displayrelation" .= rel]))