git.iko.soy/project-m36
on fd05d50 help sign in
project-m36/src/bin/ProjectM36/Server/WebSocket.hs
94 lines 6.0 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
18websocketProxyServer :: Port -> Hostname -> WS.ServerApp
19websocketProxyServer port host pending = do
20 conn <- WS.acceptRequest pending
21 let unexpectedMsg = WS.sendTextData conn ("messagenotexpected" :: T.Text)
22 --phase 1- accept database name for connection
23 dbmsg <- WS.receiveData conn :: IO T.Text
24 let connectdbmsg = "connectdb:"
25 if not (connectdbmsg `T.isPrefixOf` dbmsg) then unexpectedMsg >> WS.sendClose conn ("" :: T.Text)
26 else do
27 let dbname = T.unpack $ T.drop (T.length connectdbmsg) dbmsg
28 bracket (createConnection conn dbname port host)
29 (\eDBconn -> case eDBconn of
30 Right dbconn -> close dbconn
31 Left _ -> pure ()) $ \eDBconn ->
32 case eDBconn of
33 Left err -> sendError conn err
34 Right dbconn -> do
35 eSessionId <- createSessionAtHead dbconn "master"
36 case eSessionId of
37 Left err -> sendError conn err
38 Right sessionId -> do
39 --phase 2- accept tutoriald commands
40 _ <- forever $ do
41 pInfo <- promptInfo sessionId dbconn
42 --figure out why sending three times during startup is necessary
43 sendPromptInfo pInfo conn
44 sendPromptInfo pInfo conn
45 msg <- WS.receiveData conn :: IO T.Text
46 let tutdprefix = "executetutd:"
47 case msg of
48 _ | tutdprefix `T.isPrefixOf` msg -> do
49 let tutdString = T.drop (T.length tutdprefix) msg
50 case parseTutorialD tutdString of
51 Left err -> handleOpResult conn dbconn (DisplayErrorResult ("parse error: " `T.append` T.pack (show err)))
52 Right parsed -> do
53 let timeoutFilter exc = if exc == RequestTimeoutException
54 then Just exc
55 else Nothing
56 responseHandler = do
57 result <- evalTutorialD sessionId dbconn SafeEvaluation parsed
58 pInfo' <- promptInfo sessionId dbconn
59 sendPromptInfo pInfo' conn
60 handleOpResult conn dbconn result
61 catchJust timeoutFilter responseHandler (\_ -> handleOpResult conn dbconn (DisplayErrorResult "Request Timed Out."))
62 _ -> unexpectedMsg
63 pure ()
65notificationCallback :: WS.Connection -> NotificationCallback
66notificationCallback conn notifName evaldNotif = WS.sendTextData conn (encode (object ["notificationname" .= notifName,
67 "evaldnotification" .= evaldNotif
68 ]))
70--this creates a new database for each connection- perhaps not what we want (?)
71createConnection :: WS.Connection -> DatabaseName -> Port -> Hostname -> IO (Either ConnectionError Connection)
72createConnection wsconn dbname port host = connectProjectM36 (RemoteProcessConnectionInfo dbname (createNodeId host port) (notificationCallback wsconn))
74sendError :: (ToJSON a) => WS.Connection -> a -> IO ()
75sendError conn err = WS.sendTextData conn (encode (object ["displayerror" .= err]))
77handleOpResult :: WS.Connection -> Connection -> TutorialDOperatorResult -> IO ()
78handleOpResult conn db QuitResult = WS.sendClose conn ("close" :: T.Text) >> close db
79handleOpResult conn _ (DisplayResult out) = WS.sendTextData conn (encode (object ["display" .= out]))
80handleOpResult _ _ (DisplayIOResult ioout) = ioout
81handleOpResult conn _ (DisplayErrorResult err) = WS.sendTextData conn (encode (object ["displayerror" .= err]))
82handleOpResult conn _ (DisplayParseErrorResult _ err) = WS.sendTextData conn (encode (object ["displayparseerrorresult" .= show err]))
83handleOpResult conn _ QuietSuccessResult = WS.sendTextData conn (encode (object ["acknowledged" .= True]))
84handleOpResult conn _ (DisplayRelationResult rel) = WS.sendTextData conn (encode (object ["displayrelation" .= rel]))
86-- get current schema and head name for client
87promptInfo :: SessionId -> Connection -> IO (HeadName, SchemaName)
88promptInfo sessionId conn = do
89 eHeadName <- headName sessionId conn
90 eSchemaName <- currentSchemaName sessionId conn
91 pure (either (const "<unknown>") id eHeadName, either (const "<no schema>") id eSchemaName)
93sendPromptInfo :: (HeadName, SchemaName) -> WS.Connection -> IO ()
94sendPromptInfo (hName, sName) conn = WS.sendTextData conn (encode (object ["promptInfo" .= object ["headname" .= hName, "schemaname" .= sName]]))