git.iko.soy/project-m36
on d37e7fb help sign in
project-m36/src/bin/ProjectM36/Server/WebSocket.hs
145 lines 8.2 kB history raw
1{-# LANGUAGE LambdaCase, CPP #-}
2module ProjectM36.Server.WebSocket where
3-- 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
4-- 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
6-- launch the project-m36-server
7-- proxy all connections to it through ProjectM36.Client
8import Control.Monad (forever)
9import qualified Data.Text as T
10import qualified Network.WebSockets as WS
11import ProjectM36.Server.RemoteCallTypes.Json ()
12import ProjectM36.Client.Json ()
13import ProjectM36.DataFrame
14import ProjectM36.Relation.Show.Term
15import ProjectM36.Relation.Show.HTML
16import Data.Aeson
17import TutorialD.Interpreter
18import TutorialD.Interpreter.Base (TutorialDOperatorResult(..))
19import ProjectM36.Client
20import Control.Exception
21import Data.Attoparsec.Text
22import Control.Applicative
23import Text.Megaparsec.Error
24import Data.Functor
26#if MIN_VERSION_megaparsec(7,0,0)
27import Data.List.NonEmpty as NE
28#endif
30websocketProxyServer :: Port -> Hostname -> WS.ServerApp
31websocketProxyServer port host pending = do
32 conn <- WS.acceptRequest pending
33 let unexpectedMsg = WS.sendTextData conn ("messagenotexpected" :: T.Text)
34 --phase 1- accept database name for connection
35 dbmsg <- WS.receiveData conn :: IO T.Text
36 let connectdbmsg = "connectdb:"
37 if not (connectdbmsg `T.isPrefixOf` dbmsg) then unexpectedMsg >> WS.sendClose conn ("" :: T.Text)
38 else do
39 let dbname = T.unpack $ T.drop (T.length connectdbmsg) dbmsg
40 bracket (createConnection conn dbname port host)
41 (\case
42 Right dbconn -> close dbconn
43 Left _ -> pure ()) $ \case
44 Left err -> sendError conn err
45 Right dbconn -> do
46 eSessionId <- createSessionAtHead dbconn "master"
47 case eSessionId of
48 Left err -> sendError conn err
49 Right sessionId -> do
50 --phase 2- accept tutoriald commands
51 _ <- forever $ do
52 pInfo <- promptInfo sessionId dbconn
53 --figure out why sending three times during startup is necessary
54 sendPromptInfo pInfo conn
55 sendPromptInfo pInfo conn
56 msg <- WS.receiveData conn :: IO T.Text
57 case parseOnly parseExecuteMessage msg of
58 Left _ -> unexpectedMsg
59 Right (presentation, tutdString) ->
60 case parseTutorialD tutdString of
61 Left err -> handleOpResult conn dbconn presentation
62#if MIN_VERSION_megaparsec(7,0,0)
63 (DisplayErrorResult
64 ("parse error: " `T.append` T.pack
65 (parseErrorPretty . NE.head . bundleErrors $ err)))
66#else
67 (DisplayErrorResult ("parse error: " `T.append` T.pack (parseErrorPretty err)))
68#endif
69 Right parsed -> do
70 let timeoutFilter exc = if exc == RequestTimeoutException
71 then Just exc
72 else Nothing
73 responseHandler = do
74 result <- evalTutorialD sessionId dbconn SafeEvaluation parsed
75 pInfo' <- promptInfo sessionId dbconn
76 sendPromptInfo pInfo' conn
77 handleOpResult conn dbconn presentation result
78 catchJust timeoutFilter responseHandler (\_ -> handleOpResult conn dbconn presentation (DisplayErrorResult "Request Timed Out."))
79 pure ()
81notificationCallback :: WS.Connection -> NotificationCallback
82notificationCallback conn notifName evaldNotif = WS.sendTextData conn (encode (object ["notificationname" .= notifName,
83 "evaldnotification" .= evaldNotif
84 ]))
86--this creates a new database for each connection- perhaps not what we want (?)
87createConnection :: WS.Connection -> DatabaseName -> Port -> Hostname -> IO (Either ConnectionError Connection)
88createConnection wsconn dbname port host = connectProjectM36 (RemoteProcessConnectionInfo dbname (createNodeId host port) (notificationCallback wsconn))
90sendError :: (ToJSON a) => WS.Connection -> a -> IO ()
91sendError conn err = WS.sendTextData conn (encode (object ["displayerror" .= err]))
93handleOpResult :: WS.Connection -> Connection -> Presentation -> TutorialDOperatorResult -> IO ()
94handleOpResult conn db _ QuitResult = WS.sendClose conn ("close" :: T.Text) >> close db
95handleOpResult conn _ _ (DisplayResult out) = WS.sendTextData conn (encode (object ["display" .= out]))
96handleOpResult _ _ _ (DisplayIOResult ioout) = ioout
97handleOpResult conn _ presentation (DisplayErrorResult err) = do
98 let jsono = ["json" .= err | jsonPresentation presentation]
99 texto = ["text" .= err | textPresentation presentation]
100 htmlo = ["html" .= err | htmlPresentation presentation]
101 WS.sendTextData conn (encode (object ["displayerror" .= object (jsono ++ texto ++ htmlo)]))
102handleOpResult conn _ _ (DisplayParseErrorResult _ err) = WS.sendTextData conn (encode (object ["displayparseerrorresult" .= show err]))
103handleOpResult conn _ _ QuietSuccessResult = WS.sendTextData conn (encode (object ["acknowledged" .= True]))
104handleOpResult conn _ presentation (DisplayRelationResult rel) = do
105 let jsono = ["json" .= rel | jsonPresentation presentation]
106 texto = ["text" .= showRelation rel | textPresentation presentation]
107 htmlo = ["html" .= relationAsHTML rel | htmlPresentation presentation]
108 WS.sendTextData conn (encode (object ["displayrelation" .= object (jsono ++ texto ++ htmlo)]))
109handleOpResult conn _ presentation (DisplayDataFrameResult df) = do
110 let jsono = ["json" .= df | jsonPresentation presentation]
111 texto = ["text" .= showDataFrame df | textPresentation presentation]
112 htmlo = ["html" .= dataFrameAsHTML df | htmlPresentation presentation]
113 WS.sendTextData conn (encode (object ["displaydataframe" .= object (jsono ++ texto ++ htmlo)]))
115-- get current schema and head name for client
116promptInfo :: SessionId -> Connection -> IO (HeadName, SchemaName)
117promptInfo sessionId conn = do
118 eHeadName <- headName sessionId conn
119 eSchemaName <- currentSchemaName sessionId conn
120 pure (either (const "<unknown>") id eHeadName, either (const "<no schema>") id eSchemaName)
122sendPromptInfo :: (HeadName, SchemaName) -> WS.Connection -> IO ()
123sendPromptInfo (hName, sName) conn = WS.sendTextData conn (encode (object ["promptInfo" .= object ["headname" .= hName, "schemaname" .= sName]]))
125--a returning relation can be returned as JSON, Text (for consoles), or HTML
126data Presentation = Presentation {
127 jsonPresentation :: Bool,
128 textPresentation :: Bool,
129 htmlPresentation :: Bool }
131data PresentationFlag = JSONFlag | TextFlag | HTMLFlag
133parseExecuteMessage :: Parser (Presentation, T.Text)
134parseExecuteMessage = do
135 _ <- string "executetutd/"
136 flags <- sepBy ((string "json" $> JSONFlag) <|>
137 (string "text" $> TextFlag) <|>
138 (string "html" $> HTMLFlag)) "+"
139 let presentation = foldr (\flag acc -> case flag of
140 JSONFlag -> acc {jsonPresentation = True}
141 TextFlag -> acc {textPresentation = True}
142 HTMLFlag -> acc {htmlPresentation = True}) (Presentation False False False) flags
143 _ <- char ':'
144 tutd <- T.pack <$> manyTill anyChar endOfInput
145 pure (presentation, tutd)