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.Relation.Show.Term

14import ProjectM36.Relation.Show.HTML

15import Data.Aeson

16import TutorialD.Interpreter

17import TutorialD.Interpreter.Base

18import ProjectM36.Client

19import Control.Exception

20import Data.Attoparsec.Text

21import Control.Applicative

22import Text.Megaparsec.Error

23import Data.Functor

24

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

26websocketProxyServer port host pending = do

27 conn <- WS.acceptRequest pending

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

29 --phase 1- accept database name for connection

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

31 let connectdbmsg = "connectdb:"

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

33 else do

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

35 bracket (createConnection conn dbname port host)

36 (\case

37 Right dbconn -> close dbconn

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

39 Left err -> sendError conn err

40 Right dbconn -> do

41 eSessionId <- createSessionAtHead dbconn "master"

42 case eSessionId of

43 Left err -> sendError conn err

44 Right sessionId -> do

45 --phase 2- accept tutoriald commands

46 _ <- forever $ do

47 pInfo <- promptInfo sessionId dbconn

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

49 sendPromptInfo pInfo conn

50 sendPromptInfo pInfo conn

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

52 case parseOnly parseExecuteMessage msg of

53 Left _ -> unexpectedMsg

54 Right (presentation, tutdString) ->

55 case parseTutorialD tutdString of

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

57 Right parsed -> do

58 let timeoutFilter exc = if exc == RequestTimeoutException

59 then Just exc

60 else Nothing

61 responseHandler = do

62 result <- evalTutorialD sessionId dbconn SafeEvaluation parsed

63 pInfo' <- promptInfo sessionId dbconn

64 sendPromptInfo pInfo' conn

65 handleOpResult conn dbconn presentation result

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

67 pure ()

68

69notificationCallback :: WS.Connection -> NotificationCallback

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

71 "evaldnotification" .= evaldNotif

72 ]))

73

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

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

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

77

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

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

80

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

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

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

84handleOpResult _ _ _ (DisplayIOResult ioout) = ioout

85handleOpResult conn _ presentation (DisplayErrorResult err) = do

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

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

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

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

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

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

92handleOpResult conn _ presentation (DisplayRelationResult rel) = do

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

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

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

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

97-- get current schema and head name for client

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

99promptInfo sessionId conn = do

100 eHeadName <- headName sessionId conn

101 eSchemaName <- currentSchemaName sessionId conn

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

103

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

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

106

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

108data Presentation = Presentation {

109 jsonPresentation :: Bool,

110 textPresentation :: Bool,

111 htmlPresentation :: Bool }

112

113data PresentationFlag = JSONFlag | TextFlag | HTMLFlag

114

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

116parseExecuteMessage = do

117 _ <- string "executetutd/"

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

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

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

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

122 JSONFlag -> acc {jsonPresentation = True}

123 TextFlag -> acc {textPresentation = True}

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

125 _ <- char ':'

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

127 pure (presentation, tutd)