src/bin/ProjectM36/Server/WebSocket.hs · project-m36

1{-# LANGUAGE LambdaCase #-}

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

5

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

25

26websocketProxyServer :: Port -> Hostname -> WS.ServerApp

27websocketProxyServer port host pending = do

28 conn <- WS.acceptRequest pending

29 let unexpectedMsg = WS.sendTextData conn ("messagenotexpected" :: T.Text)

30 --phase 1- accept database name for connection

31 dbmsg <- WS.receiveData conn :: IO T.Text

32 let connectdbmsg = "connectdb:"

33 if not (connectdbmsg `T.isPrefixOf` dbmsg) then unexpectedMsg >> WS.sendClose conn ("" :: T.Text)

34 else do

35 let dbname = T.unpack $ T.drop (T.length connectdbmsg) dbmsg

36 bracket (createConnection conn dbname port host)

37 (\case

38 Right dbconn -> close dbconn

39 Left _ -> pure ()) $ \case

40 Left err -> sendError conn err

41 Right dbconn -> do

42 eSessionId <- createSessionAtHead dbconn "master"

43 case eSessionId of

44 Left err -> sendError conn err

45 Right sessionId -> do

46 --phase 2- accept tutoriald commands

47 _ <- forever $ do

48 pInfo <- promptInfo sessionId dbconn

49 --figure out why sending three times during startup is necessary

50 sendPromptInfo pInfo conn

51 sendPromptInfo pInfo conn

52 msg <- WS.receiveData conn :: IO T.Text

53 case parseOnly parseExecuteMessage msg of

54 Left _ -> unexpectedMsg

55 Right (presentation, tutdString) ->

56 case parseTutorialD tutdString of

57 Left err -> handleOpResult conn dbconn presentation (DisplayErrorResult ("parse error: " `T.append` T.pack (parseErrorPretty err)))

58 Right parsed -> do

59 let timeoutFilter exc = if exc == RequestTimeoutException

60 then Just exc

61 else Nothing

62 responseHandler = do

63 result <- evalTutorialD sessionId dbconn SafeEvaluation parsed

64 pInfo' <- promptInfo sessionId dbconn

65 sendPromptInfo pInfo' conn

66 handleOpResult conn dbconn presentation result

67 catchJust timeoutFilter responseHandler (\_ -> handleOpResult conn dbconn presentation (DisplayErrorResult "Request Timed Out."))

68 pure ()

69

70notificationCallback :: WS.Connection -> NotificationCallback

71notificationCallback conn notifName evaldNotif = WS.sendTextData conn (encode (object ["notificationname" .= notifName,

72 "evaldnotification" .= evaldNotif

73 ]))

74

75--this creates a new database for each connection- perhaps not what we want (?)

76createConnection :: WS.Connection -> DatabaseName -> Port -> Hostname -> IO (Either ConnectionError Connection)

77createConnection wsconn dbname port host = connectProjectM36 (RemoteProcessConnectionInfo dbname (createNodeId host port) (notificationCallback wsconn))

78

79sendError :: (ToJSON a) => WS.Connection -> a -> IO ()

80sendError conn err = WS.sendTextData conn (encode (object ["displayerror" .= err]))

81

82handleOpResult :: WS.Connection -> Connection -> Presentation -> TutorialDOperatorResult -> IO ()

83handleOpResult conn db _ QuitResult = WS.sendClose conn ("close" :: T.Text) >> close db

84handleOpResult conn _ _ (DisplayResult out) = WS.sendTextData conn (encode (object ["display" .= out]))

85handleOpResult _ _ _ (DisplayIOResult ioout) = ioout

86handleOpResult conn _ presentation (DisplayErrorResult err) = do

87 let jsono = ["json" .= err | jsonPresentation presentation]

88 texto = ["text" .= err | textPresentation presentation]

89 htmlo = ["html" .= err | htmlPresentation presentation]

90 WS.sendTextData conn (encode (object ["displayerror" .= object (jsono ++ texto ++ htmlo)]))

91handleOpResult conn _ _ (DisplayParseErrorResult _ err) = WS.sendTextData conn (encode (object ["displayparseerrorresult" .= show err]))

92handleOpResult conn _ _ QuietSuccessResult = WS.sendTextData conn (encode (object ["acknowledged" .= True]))

93handleOpResult conn _ presentation (DisplayRelationResult rel) = do

94 let jsono = ["json" .= rel | jsonPresentation presentation]

95 texto = ["text" .= showRelation rel | textPresentation presentation]

96 htmlo = ["html" .= relationAsHTML rel | htmlPresentation presentation]

97 WS.sendTextData conn (encode (object ["displayrelation" .= object (jsono ++ texto ++ htmlo)]))

98handleOpResult conn _ presentation (DisplayDataFrameResult df) = do

99 let jsono = ["json" .= df | jsonPresentation presentation]

100 texto = ["text" .= showDataFrame df | textPresentation presentation]

101 htmlo = ["html" .= dataFrameAsHTML df | htmlPresentation presentation]

102 WS.sendTextData conn (encode (object ["displaydataframe" .= object (jsono ++ texto ++ htmlo)]))

103

104-- get current schema and head name for client

105promptInfo :: SessionId -> Connection -> IO (HeadName, SchemaName)

106promptInfo sessionId conn = do

107 eHeadName <- headName sessionId conn

108 eSchemaName <- currentSchemaName sessionId conn

109 pure (either (const "<unknown>") id eHeadName, either (const "<no schema>") id eSchemaName)

110

111sendPromptInfo :: (HeadName, SchemaName) -> WS.Connection -> IO ()

112sendPromptInfo (hName, sName) conn = WS.sendTextData conn (encode (object ["promptInfo" .= object ["headname" .= hName, "schemaname" .= sName]]))

113

114--a returning relation can be returned as JSON, Text (for consoles), or HTML

115data Presentation = Presentation {

116 jsonPresentation :: Bool,

117 textPresentation :: Bool,

118 htmlPresentation :: Bool }

119

120data PresentationFlag = JSONFlag | TextFlag | HTMLFlag

121

122parseExecuteMessage :: Parser (Presentation, T.Text)

123parseExecuteMessage = do

124 _ <- string "executetutd/"

125 flags <- sepBy ((string "json" $> JSONFlag) <|>

126 (string "text" $> TextFlag) <|>

127 (string "html" $> HTMLFlag)) "+"

128 let presentation = foldr (\flag acc -> case flag of

129 JSONFlag -> acc {jsonPresentation = True}

130 TextFlag -> acc {textPresentation = True}

131 HTMLFlag -> acc {htmlPresentation = True}) (Presentation False False False) flags

132 _ <- char ':'

133 tutd <- T.pack <$> manyTill anyChar endOfInput

134 pure (presentation, tutd)