git.iko.soy/project-m36
on 8cfc3ee help sign in
project-m36/src/bin/ProjectM36/Server/WebSocket.hs
73 lines 4.3 kB history raw
1module 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
5-- launch the project-m36-server
6-- proxy all connections to it through ProjectM36.Client
7import Control.Monad (forever)
8import qualified Data.Text as T
9import qualified Network.WebSockets as WS
10import ProjectM36.Server.RemoteCallTypes.Json ()
11import ProjectM36.Client.Json ()
12import Data.Aeson
13import TutorialD.Interpreter
14import TutorialD.Interpreter.Base
15import ProjectM36.Client
16import Control.Exception
18-- | Called when the project-m36-server exits.
19failureHandler :: Either SomeException Bool -> IO ()
20failureHandler = error "project-m36-server exited unexpectedly"
22websocketProxyServer :: Port -> Hostname -> WS.ServerApp
23websocketProxyServer port host pending = do
24 conn <- WS.acceptRequest pending
25 let unexpectedMsg = WS.sendTextData conn ("messagenotexpected" :: T.Text)
26 --phase 1- accept database name for connection
27 dbmsg <- (WS.receiveData conn) :: IO T.Text
28 let connectdbmsg = "connectdb:"
29 if not (connectdbmsg `T.isPrefixOf` dbmsg) then unexpectedMsg >> WS.sendClose conn ("" :: T.Text)
30 else do
31 let dbname = T.unpack $ T.drop (T.length connectdbmsg) dbmsg
32 eDbconn <- createConnection conn dbname port host
33 case eDbconn of
34 Left err -> sendError conn err
35 Right dbconn -> do
36 eSessionId <- createSessionAtHead "master" dbconn
37 case eSessionId of
38 Left err -> sendError conn err
39 Right sessionId -> do
40 --phase 2- accept tutoriald commands
41 _ <- forever $ do
42 msg <- (WS.receiveData conn) :: IO T.Text
43 let tutdprefix = "executetutd:"
44 case msg of
45 _ | tutdprefix `T.isPrefixOf` msg -> do
46 let tutdString = T.drop (T.length tutdprefix) msg
47 case parseTutorialD tutdString of
48 Left err -> handleOpResult conn dbconn (DisplayErrorResult ("parse error: " `T.append` T.pack (show err)))
49 Right parsed -> do
50 result <- evalTutorialD sessionId dbconn SafeEvaluation parsed
51 handleOpResult conn dbconn result
52 _ -> unexpectedMsg
53 pure ()
55notificationCallback :: WS.Connection -> NotificationCallback
56notificationCallback conn notifName evaldNotif = WS.sendTextData conn (encode (object ["notificationname" .= notifName,
57 "evaldnotification" .= evaldNotif
58 ]))
60--this creates a new database for each connection- perhaps not what we want (?)
61createConnection :: WS.Connection -> DatabaseName -> Port -> Hostname -> IO (Either ConnectionError Connection)
62createConnection wsconn dbname port host = connectProjectM36 (RemoteProcessConnectionInfo dbname (createNodeId host port) (notificationCallback wsconn))
64sendError :: (ToJSON a) => WS.Connection -> a -> IO ()
65sendError conn err = WS.sendTextData conn (encode (object ["displayerror" .= err]))
67handleOpResult :: WS.Connection -> Connection -> TutorialDOperatorResult -> IO ()
68handleOpResult conn db QuitResult = WS.sendClose conn ("close" :: T.Text) >> close db
69handleOpResult conn _ (DisplayResult out) = WS.sendTextData conn (encode (object ["display" .= out]))
70handleOpResult _ _ (DisplayIOResult ioout) = ioout
71handleOpResult conn _ (DisplayErrorResult err) = WS.sendTextData conn (encode (object ["displayerror" .= err]))
72handleOpResult conn _ QuietSuccessResult = WS.sendTextData conn (encode (object ["acknowledged" .= True]))
73handleOpResult conn _ (DisplayRelationResult rel) = WS.sendTextData conn (encode (object ["displayrelation" .= rel]))