diff --git a/Changelog.markdown b/Changelog.markdown --- a/Changelog.markdown +++ b/Changelog.markdown @@ -1,3 +1,9 @@ +# 2024-07-27 (v1.0.2) + +* upgrade to streamly 0.10.1 +* refactor websocket API to support request UUIDs (#367) +* refactor websocket API to support `createSessionAtHead` (#367) + # 2024-07-15 (v1.0.1) * add support for aggregate functions using sub-relation attributes diff --git a/project-m36.cabal b/project-m36.cabal --- a/project-m36.cabal +++ b/project-m36.cabal @@ -1,6 +1,6 @@ Cabal-Version: 2.2 Name: project-m36 -Version: 1.0.1 +Version: 1.0.2 License: MIT --note that this license specification is erroneous and only labeled MIT to appease hackage which does not recognize public domain packages in cabal >2.2- Project:M36 is dedicated to the public domain Build-Type: Simple @@ -36,7 +36,67 @@ Default: True Library - Build-Depends: base>=4.16 && < 4.19, ghc-paths, mtl, containers, unordered-containers, hashable, haskeline, directory, MonadRandom, random-shuffle, uuid >= 1.3.12, cassava >= 0.4.5.1 && < 0.6, text, bytestring, deepseq, deepseq-generics, vector, parallel, monad-parallel, exceptions, transformers, gnuplot, filepath, zlib, directory, temporary, stm, time, old-locale, rset, attoparsec, either, base64-bytestring, data-interval, extended-reals, aeson >= 1.1, path-pieces, conduit, resourcet, http-api-data, semigroups, QuickCheck, quickcheck-instances, list-t, stm-containers >= 0.2.15, foldl, optparse-applicative, Glob, cryptohash-sha256, text-manipulate >= 0.2.0.1 && < 0.4, winery >= 1.4, curryer-rpc>=0.3.5, network, async, vector-instances, recursion-schemes, streamly == 0.9.0, convertible, fast-builder, scientific + Build-Depends: + base>=4.16 && < 4.19, + ghc-paths, + mtl, + containers, + unordered-containers, + hashable, + haskeline, + directory, + MonadRandom, + random-shuffle, + uuid >= 1.3.12, + cassava >= 0.4.5.1 && < 0.6, + text, + bytestring, + deepseq, + deepseq-generics, + vector, + parallel, + monad-parallel, + exceptions, + transformers, + gnuplot, + filepath, + zlib, + directory, + temporary, + stm, + time, + old-locale, + rset, + attoparsec, + either, + base64-bytestring, + data-interval, + extended-reals, + aeson >= 1.1, + path-pieces, + conduit, + resourcet, + http-api-data, + semigroups, + QuickCheck, + quickcheck-instances, + list-t, + stm-containers >= 0.2.15, + foldl, + optparse-applicative, + Glob, + cryptohash-sha256, + text-manipulate >= 0.2.0.1 && < 0.4, + winery >= 1.4, + curryer-rpc>=0.3.6, + network, + async, + vector-instances, + recursion-schemes, + streamly == 0.10.1, + convertible, + fast-builder, + scientific if flag(haskell-scripting) Build-Depends: ghc >= 9.0 && < 9.5 CPP-Options: -DPM36_HASKELL_SCRIPTING @@ -566,7 +626,7 @@ import: commontest type: exitcode-stdio-1.0 main-is: Server/WebSocket.hs - Other-Modules: TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.TransactionGraphOperator, ProjectM36.Client.Json, ProjectM36.Server.RemoteCallTypes.Json, ProjectM36.Server.WebSocket, TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.Types, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.SchemaOperator, TutorialD.Printer + Other-Modules: TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.TransactionGraphOperator, ProjectM36.Client.Json, ProjectM36.Server.RemoteCallTypes.Json, ProjectM36.Server.WebSocket, TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.Types, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.SchemaOperator, TutorialD.Printer, ProjectM36.Interpreter Test-Suite test-isomorphic-schemas import: commontest diff --git a/src/bin/ProjectM36/Server/RemoteCallTypes/Json.hs b/src/bin/ProjectM36/Server/RemoteCallTypes/Json.hs --- a/src/bin/ProjectM36/Server/RemoteCallTypes/Json.hs +++ b/src/bin/ProjectM36/Server/RemoteCallTypes/Json.hs @@ -110,6 +110,11 @@ "val" .= u ] toJSON atom@(RelationAtom i) = object [ "type" .= atomTypeForAtom atom, "val" .= i ] + toJSON atom@(SubrelationFoldAtom rel attrName) = object [ "type" .= atomTypeForAtom atom, + "val" .= + object [ "relation" .= rel, + "attributeName" .= attrName] + ] toJSON atom@(RelationalExprAtom i) = object [ "type" .= atomTypeForAtom atom, "val" .= i ] toJSON (ConstructedAtom dConsName atomtype atomlist) = object [ @@ -148,6 +153,9 @@ Just u -> pure $ UUIDAtom u Nothing -> fail "Invalid UUID String" RelationalExprAtomType -> RelationalExprAtom <$> o .: "val" + SubrelationFoldAtomType _ -> do + val <- o .: "val" + SubrelationFoldAtom <$> val .: "relation" <*> val .: "attributeName" instance ToJSON Notification instance FromJSON Notification diff --git a/src/bin/ProjectM36/Server/WebSocket.hs b/src/bin/ProjectM36/Server/WebSocket.hs --- a/src/bin/ProjectM36/Server/WebSocket.hs +++ b/src/bin/ProjectM36/Server/WebSocket.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE LambdaCase, CPP #-} +{-# LANGUAGE LambdaCase, CPP, GeneralizedNewtypeDeriving, DeriveAnyClass, DeriveGeneric, DerivingStrategies, ScopedTypeVariables #-} module ProjectM36.Server.WebSocket where -- 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 -- 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 @@ -14,15 +14,17 @@ import ProjectM36.Relation.Show.Term import ProjectM36.Relation.Show.HTML import Data.Aeson +import ProjectM36.Base import TutorialD.Interpreter import ProjectM36.Interpreter (ConsoleResult(..), SafeEvaluationFlag(..)) import ProjectM36.Client import Control.Exception -import Data.Attoparsec.Text -import Control.Applicative import Text.Megaparsec.Error -import Data.Functor import Data.Either (fromRight) +import qualified Data.ByteString.Lazy as BS +import qualified Data.UUID as UUID +import GHC.Generics +import qualified Data.Text.Encoding as TE #if MIN_VERSION_megaparsec(7,0,0) import Data.List.NonEmpty as NE @@ -31,94 +33,119 @@ websocketProxyServer :: Port -> Hostname -> WS.ServerApp websocketProxyServer port host pending = do conn <- WS.acceptRequest pending - let unexpectedMsg = WS.sendTextData conn ("messagenotexpected" :: T.Text) + let unexpectedMsg expecting received = do + print (expecting, received) + sendResponse conn (MessageNotExpected expecting) --phase 1- accept database name for connection - dbmsg <- WS.receiveData conn :: IO T.Text - let connectdbmsg = "connectdb:" - if not (connectdbmsg `T.isPrefixOf` dbmsg) then unexpectedMsg >> WS.sendClose conn ("" :: T.Text) - else do - let dbname = T.unpack $ T.drop (T.length connectdbmsg) dbmsg + dbmsg <- WS.receiveData conn :: IO BS.ByteString + case eitherDecode dbmsg of + Left _ -> do + unexpectedMsg "ConnectionSetupRequest" dbmsg + WS.sendClose conn ("" :: T.Text) + Right (ConnectionSetupRequest dbname) -> do bracket (createConnection conn dbname port host) (\case Right dbconn -> close dbconn Left _ -> pure ()) $ \case - Left err -> sendError conn err + Left err -> sendResponse conn (TextErrorResponse (RequestId UUID.nil) (T.pack (show err))) Right dbconn -> do - eSessionId <- createSessionAtHead dbconn "master" - case eSessionId of - Left err -> sendError conn err - Right sessionId -> do - --phase 2- accept tutoriald commands - _ <- forever $ do - pInfo <- promptInfo sessionId dbconn - --figure out why sending three times during startup is necessary - sendPromptInfo pInfo conn - sendPromptInfo pInfo conn - msg <- WS.receiveData conn :: IO T.Text - case parseOnly parseExecuteMessage msg of - Left _ -> unexpectedMsg - Right (presentation, tutdString) -> + sendResponse conn ConnectionSetupResponse + --phase 2- accept tutoriald commands + _ <- forever $ do + {-pInfo <- promptInfo sessionId dbconn + --figure out why sending three times during startup is necessary + sendPromptInfo pInfo conn + sendPromptInfo pInfo conn-} + msg <- WS.receiveData conn :: IO BS.ByteString + case eitherDecode msg of + Left err -> unexpectedMsg "Request" err + Right (CreateSessionAtHeadRequest reqId branchName) -> do + ret <- createSessionAtHead dbconn branchName + case ret of + Left err -> sendResponse conn (RelationalErrorResponse reqId err) + Right sessionId -> sendResponse conn (CreateSessionAtHeadResponse reqId sessionId) + Right (ExecuteTutorialDRequest reqId sessionId presentation (TutorialDText tutdString)) -> case parseTutorialD tutdString of - Left err -> handleOpResult conn dbconn presentation -#if MIN_VERSION_megaparsec(7,0,0) - (DisplayErrorResult - ("parse error: " `T.append` T.pack - (parseErrorPretty . NE.head . bundleErrors $ err))) -#else - (DisplayErrorResult ("parse error: " `T.append` T.pack (parseErrorPretty err))) -#endif + Left err -> do + let parseErr = ParseError $ T.pack + (parseErrorPretty . NE.head . bundleErrors $ err) + + sendResponse conn (RelationalErrorResponse reqId parseErr) Right parsed -> do let timeoutFilter exc = if exc == RequestTimeoutException then Just exc else Nothing responseHandler = do result <- evalTutorialD sessionId dbconn SafeEvaluation parsed - pInfo' <- promptInfo sessionId dbconn - sendPromptInfo pInfo' conn - handleOpResult conn dbconn presentation result - catchJust timeoutFilter responseHandler (\_ -> handleOpResult conn dbconn presentation (DisplayErrorResult "Request Timed Out.")) - pure () + (headName', schemaName) <- promptInfo sessionId dbconn + sendResponse conn (PromptInfoResponse sessionId headName' schemaName) + let resp = makeResponse reqId presentation result + handleResponse conn dbconn resp + catchJust timeoutFilter responseHandler (\_ -> + sendResponse conn (TimeoutResponse reqId)) + pure () + notificationCallback :: WS.Connection -> NotificationCallback -notificationCallback conn notifName evaldNotif = WS.sendTextData conn (encode (object ["notificationname" .= notifName, - "evaldnotification" .= evaldNotif - ])) +notificationCallback conn notifName evaldNotif = + sendResponse conn (NotificationResponse notifName evaldNotif) --this creates a new database for each connection- perhaps not what we want (?) createConnection :: WS.Connection -> DatabaseName -> Port -> Hostname -> IO (Either ConnectionError Connection) createConnection wsconn dbname port host = connectProjectM36 (RemoteConnectionInfo dbname host (show port) (notificationCallback wsconn)) -sendError :: (ToJSON a) => WS.Connection -> a -> IO () -sendError conn err = WS.sendTextData conn (encode (object ["displayerror" .= err])) - -handleOpResult :: WS.Connection -> Connection -> Presentation -> ConsoleResult -> IO () -handleOpResult conn db _ QuitResult = WS.sendClose conn ("close" :: T.Text) >> close db -handleOpResult conn _ _ (DisplayResult out) = WS.sendTextData conn (encode (object ["display" .= out])) -handleOpResult _ _ _ (DisplayIOResult ioout) = ioout -handleOpResult conn _ presentation (DisplayErrorResult err) = do - let jsono = ["json" .= err | jsonPresentation presentation] - texto = ["text" .= err | textPresentation presentation] - htmlo = ["html" .= err | htmlPresentation presentation] - WS.sendTextData conn (encode (object ["displayerror" .= object (jsono ++ texto ++ htmlo)])) -handleOpResult conn _ _ (DisplayParseErrorResult _ err) = WS.sendTextData conn (encode (object ["displayparseerrorresult" .= show err])) -handleOpResult conn _ _ QuietSuccessResult = WS.sendTextData conn (encode (object ["acknowledged" .= True])) -handleOpResult conn _ presentation (DisplayRelationResult rel) = do - let jsono = ["json" .= rel | jsonPresentation presentation] - texto = ["text" .= showRelation rel | textPresentation presentation] - htmlo = ["html" .= relationAsHTML rel | htmlPresentation presentation] - WS.sendTextData conn (encode (object ["displayrelation" .= object (jsono ++ texto ++ htmlo)])) -handleOpResult conn _ presentation (DisplayDataFrameResult df) = do - let jsono = ["json" .= df | jsonPresentation presentation] - texto = ["text" .= showDataFrame df | textPresentation presentation] - htmlo = ["html" .= dataFrameAsHTML df | htmlPresentation presentation] - WS.sendTextData conn (encode (object ["displaydataframe" .= object (jsono ++ texto ++ htmlo)])) -handleOpResult conn _ _ (DisplayRelationalErrorResult relErr) = - WS.sendTextData conn (encode (object ["displayrelationalerrorresult" .= relErr])) -handleOpResult conn dbconn presentation (DisplayHintWith txt conResult) = do - -- we should wrap this up into one response instead of two responses for clarity - WS.sendTextData conn (encode (object ["hint" .= txt])) - handleOpResult conn dbconn presentation conResult - +handleResponse :: WS.Connection -> Connection -> Response -> IO () +handleResponse conn dbconn resp = + case resp of + ConnectionClosedResponse -> do + close dbconn + sendResp + DisplayTextResponse{} -> sendResp + RelationResponse{} -> sendResp + DataFrameResponse{} -> sendResp + CreateSessionAtHeadResponse{} -> sendResp + SuccessResponse{} -> sendResp + TimeoutResponse{} -> sendResp + PromptInfoResponse{} -> sendResp + RelationalErrorResponse{} -> sendResp + TextErrorResponse{} -> sendResp + HintWithResponse{} -> sendResp + ConnectionSetupResponse{} -> sendResp + NotificationResponse{} -> sendResp + MessageNotExpected{} -> sendResp + where + sendResp = sendResponse conn resp + +makeResponse :: RequestId -> Presentation -> ConsoleResult -> Response +makeResponse reqId presentation consoleResult = + case consoleResult of + QuitResult -> do + ConnectionClosedResponse + DisplayResult out -> + DisplayTextResponse reqId out + DisplayIOResult _ -> + -- we can't send it over the websocket, so just ignore it- in other context, this just used to launch plots + SuccessResponse reqId + DisplayErrorResult err -> + TextErrorResponse reqId err + DisplayParseErrorResult _ err -> + let err' = ParseError $ T.pack (parseErrorPretty . NE.head . bundleErrors $ err) in + RelationalErrorResponse reqId err' + QuietSuccessResult -> + SuccessResponse reqId + DisplayRelationResult rel -> + RelationResponse reqId rel presentation + DisplayDataFrameResult df -> + DataFrameResponse reqId df presentation + DisplayRelationalErrorResult relErr -> + RelationalErrorResponse reqId relErr + DisplayHintWith txt conResult -> + HintWithResponse reqId txt (makeResponse reqId presentation conResult) + +sendResponse :: WS.Connection -> Response -> IO () +sendResponse conn response = + -- this could be optimized to work with a lazy bytestring + WS.sendTextData conn (TE.decodeUtf8 (BS.toStrict (encode response))) -- get current schema and head name for client promptInfo :: SessionId -> Connection -> IO (HeadName, SchemaName) @@ -135,19 +162,189 @@ jsonPresentation :: Bool, textPresentation :: Bool, htmlPresentation :: Bool } + deriving (Generic, ToJSON, FromJSON) + +jsonOnlyPresentation :: Presentation +jsonOnlyPresentation = Presentation { jsonPresentation = True, + textPresentation = False, + htmlPresentation = False } + data PresentationFlag = JSONFlag | TextFlag | HTMLFlag + deriving (Generic, ToJSON, FromJSON) -parseExecuteMessage :: Parser (Presentation, T.Text) -parseExecuteMessage = do - _ <- string "executetutd/" - flags <- sepBy ((string "json" $> JSONFlag) <|> - (string "text" $> TextFlag) <|> - (string "html" $> HTMLFlag)) "+" - let presentation = foldr (\flag acc -> case flag of - JSONFlag -> acc {jsonPresentation = True} - TextFlag -> acc {textPresentation = True} - HTMLFlag -> acc {htmlPresentation = True}) (Presentation False False False) flags - _ <- char ':' - tutd <- T.pack <$> manyTill anyChar endOfInput - pure (presentation, tutd) +newtype RequestId = RequestId UUID.UUID + deriving newtype (ToJSON, FromJSON, Eq, Show) + +newtype TutorialDText = TutorialDText T.Text + deriving newtype (ToJSON, FromJSON) + +newtype ConnectionSetupRequest = ConnectionSetupRequest DatabaseName + +instance FromJSON ConnectionSetupRequest where + parseJSON = withObject "ConnectionSetupRequest" $ \o -> do + tag::T.Text <- o .: "tag" + case tag of + "ConnectionSetupRequest" -> + ConnectionSetupRequest <$> o .: "databaseName" + other -> fail ("bad tag: " <> show other) + +instance ToJSON ConnectionSetupRequest where + toJSON (ConnectionSetupRequest dbName) = + object [ "tag" .= ("ConnectionSetupRequest"::T.Text), + "databaseName" .= dbName ] + +data Request = ExecuteTutorialDRequest RequestId SessionId Presentation TutorialDText | + CreateSessionAtHeadRequest RequestId HeadName + +data Response = RelationResponse RequestId Relation Presentation | + DataFrameResponse RequestId DataFrame Presentation | + CreateSessionAtHeadResponse RequestId SessionId | + SuccessResponse RequestId | + TimeoutResponse RequestId | + PromptInfoResponse SessionId HeadName SchemaName | + RelationalErrorResponse RequestId RelationalError | + TextErrorResponse RequestId T.Text | + ConnectionClosedResponse | + ConnectionSetupResponse | + DisplayTextResponse RequestId T.Text | + HintWithResponse RequestId T.Text Response | + NotificationResponse NotificationName EvaluatedNotification | + MessageNotExpected T.Text + +instance ToJSON Request where + toJSON (ExecuteTutorialDRequest reqId sessionId presentation tutd) = + object [ "tag" .= ("ExecuteTutorialDRequest"::T.Text), + "requestId" .= reqId, + "sessionId" .= sessionId, + "presentation" .= presentation, + "tutoriald" .= tutd ] + toJSON (CreateSessionAtHeadRequest reqId headName') = + object [ "tag" .= ("CreateSessionAtHeadRequest"::T.Text), + "requestId" .= reqId, + "headName" .= headName' ] + +instance FromJSON Request where + parseJSON = withObject "ExecuteTutorialDRequest" $ \o -> do + tag::T.Text <- o .: "tag" + case tag of + "ExecuteTutorialDRequest" -> + ExecuteTutorialDRequest <$> o .: "requestId" + <*> o .: "sessionId" + <*> o .: "presentation" + <*> o .: "tutoriald" + "CreateSessionAtHeadRequest" -> + CreateSessionAtHeadRequest <$> o .: "requestId" + <*> o .: "headName" + other -> fail ("bad tag: " <> show other) + +-- this is useful for Haskell clients to decode JSON messages +instance FromJSON Response where + parseJSON = withObject "Response" $ \o -> do + tag::T.Text <- o .: "tag" + case tag of + "RelationResponse" -> do + mJsonRel <- o .: "jsonRelation" + case mJsonRel of + Nothing -> fail "missing json relation" + Just jsonRel -> + RelationResponse <$> o .: "requestId" <*> pure jsonRel <*> pure jsonOnlyPresentation + "DataFrameResponse" -> do + mJsonDF <- o .: "jsonDataFrame" + case mJsonDF of + Nothing -> fail "missing json dataframe" + Just jsonDF -> + DataFrameResponse <$> o .: "requestId" <*> pure jsonDF <*> pure jsonOnlyPresentation + "CreateSessionAtHeadResponse" -> + CreateSessionAtHeadResponse <$> o .: "requestId" <*> o .: "sessionId" + "SuccessResponse" -> + SuccessResponse <$> o .: "requestId" + "TimeoutResponse" -> + TimeoutResponse <$> o .: "requestId" + "PromptInfoResponse" -> + PromptInfoResponse <$> o .: "sessionId" <*> o .: "headName" <*> o .: "schemaName" + "RelationalErrorResponse" -> + RelationalErrorResponse <$> o .: "requestId" <*> o .: "error" + "TextErrorResponse" -> + TextErrorResponse <$> o .: "requestId" <*> o .: "error" + "ConnectionClosedResponse" -> + pure ConnectionClosedResponse + "DisplayTextResponse" -> + DisplayTextResponse <$> o .: "requestId" <*> o .: "text" + "HintWithResponse" -> + HintWithResponse <$> o .: "requestId" <*> o .: "hintText" <*> o .: "response" + "ConnectionSetupResponse" -> + pure ConnectionSetupResponse + "NotificationResponse" -> + NotificationResponse <$> o .: "notificationName" <*> o .: "evaluatedNotification" + "MessageNotExpected" -> + MessageNotExpected <$> o .: "expected" + other -> + fail ("unexpected tag: " <> T.unpack other) + +instance ToJSON Response where + toJSON (RelationResponse reqId rel presentation) = + object [ "tag" .= ("RelationResponse"::T.Text), + "requestId" .= reqId, + "jsonRelation" .= if jsonPresentation presentation then + Just rel else Nothing, + "textRelation" .= if textPresentation presentation then + Just (showRelation rel) else Nothing, + "htmlRelation" .= if htmlPresentation presentation then + Just (relationAsHTML rel) else Nothing + + ] + toJSON (DataFrameResponse reqId df presentation) = + object [ "tag" .= ("DataFrameResponse"::T.Text), + "requestId" .= reqId, + "jsonDataFrame" .= if jsonPresentation presentation then + Just df else Nothing, + "textDataFrame" .= if textPresentation presentation then + Just (showDataFrame df) else Nothing, + "htmlDataFrame" .= if htmlPresentation presentation then + Just (dataFrameAsHTML df) else Nothing + ] + toJSON (CreateSessionAtHeadResponse reqId sessionId) = + object [ "tag" .= ("CreateSessionAtHeadResponse"::T.Text), + "requestId" .= reqId, + "sessionId" .= sessionId ] + toJSON (SuccessResponse reqId) = + object [ "tag" .= ("SuccessResponse"::T.Text), + "requestId" .= reqId ] + toJSON (TimeoutResponse reqId) = + object [ "tag" .= ("TimeoutResponse"::T.Text), + "requestId" .= reqId ] + toJSON (PromptInfoResponse sessionId headName' schemaName) = + object [ "tag" .= ("PromptInfoResponse"::T.Text), + "sessionId" .= sessionId, + "headName" .= headName', + "schemaName" .= schemaName ] + toJSON (RelationalErrorResponse reqId relErr) = + object [ "tag" .= ("RelationalErrorResponse"::T.Text), + "requestId" .= reqId, + "error" .= relErr ] + toJSON (TextErrorResponse reqId err) = + object [ "tag" .= ("TextErrorResponse"::T.Text), + "requestId" .= reqId, + "error" .= err ] + toJSON ConnectionClosedResponse = + object [ "tag" .= ("ConnectionClosedResponse"::T.Text) ] + toJSON (DisplayTextResponse reqId txt) = + object [ "tag" .= ("DisplayTextResponse"::T.Text), + "requestId" .= reqId, + "text" .= txt ] + toJSON (HintWithResponse reqId hintTxt resp) = + object [ "tag" .= ("HintWithResponse"::T.Text), + "requestId" .= reqId, + "hintText" .= hintTxt, + "response" .= resp ] + toJSON ConnectionSetupResponse = + object [ "tag" .= ("ConnectionSetupResponse"::T.Text), + "status" .= ("ready"::T.Text) ] + toJSON (NotificationResponse notificationName evaldNotification) = + object [ "tag" .= ("NotificationResponse"::T.Text), + "notificationName" .= notificationName, + "evaluatedNotification" .= evaldNotification ] + toJSON (MessageNotExpected expected) = + object [ "tag" .= ("MessageNotExpected"::T.Text), + "expected" .= expected ] diff --git a/test/Server/WebSocket.hs b/test/Server/WebSocket.hs --- a/test/Server/WebSocket.hs +++ b/test/Server/WebSocket.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP, TypeApplications #-} -- test the websocket server import Test.HUnit import qualified Network.WebSockets as WS @@ -6,7 +6,6 @@ import ProjectM36.Server.Config import ProjectM36.Server import ProjectM36.Client -import ProjectM36.Base import Network.Socket import Control.Exception @@ -15,10 +14,10 @@ import Data.Typeable import Data.Text hiding (map) import Data.Aeson -import qualified Data.Map as M import qualified Data.ByteString.Lazy as BS import ProjectM36.Relation import Control.Monad (void) +import Data.UUID.V4 (nextRandom) --start the websocket server -- run some tutoriald against it @@ -75,35 +74,55 @@ basicConnection port = WS.runClient "127.0.0.1" (fromIntegral port) "/" basicConnectionWithDatabase :: PortNumber -> DatabaseName -> WS.ClientApp () -> IO () -basicConnectionWithDatabase port dbname block = basicConnection port (\conn -> do - WS.sendTextData conn ("connectdb:" `append` pack dbname) - block conn) +basicConnectionWithDatabase port dbname block = basicConnection port + (\conn -> do + --setup connection + let connectMsg = encode (ConnectionSetupRequest dbname) + WS.sendTextData conn connectMsg + setupResponse <- WS.receiveData conn + case eitherDecode setupResponse of + Left err -> error (show err) + Right ConnectionSetupResponse{} -> pure () + Right _other -> error (show setupResponse) + block conn) testBasicConnection :: PortNumber -> DatabaseName -> Test -testBasicConnection port _ = TestCase $ basicConnection port (\conn -> WS.sendClose conn ("test close"::Text)) +testBasicConnection port _ = TestCase $ basicConnection port (\conn -> WS.sendClose conn (""::Text)) testTutorialD :: PortNumber -> DatabaseName -> Test testTutorialD port dbname = TestCase $ basicConnectionWithDatabase port dbname testtutd where discardPromptInfo conn = do response <- WS.receiveData conn :: IO BS.ByteString - let decoded = decode response :: Maybe (M.Map Text (M.Map Text Text)) - case decoded of - Just _ -> pure () - Nothing -> assertFailure ("failed to decode prompt info: " ++ show response) + case eitherDecode @Response response of + Right _promptInfo -> pure () + Left err -> assertFailure ("failed to decode prompt info: " ++ err ++ ": " ++ show response) testtutd conn = do - discardPromptInfo conn - WS.sendTextData conn ("executetutd/json:" `append` ":showexpr true") - discardPromptInfo conn + -- create new session at master + reqId <- RequestId <$> nextRandom + let createSessionMsg = encode (CreateSessionAtHeadRequest reqId "master") + WS.sendTextData conn createSessionMsg + sessionResponse <- WS.receiveData conn :: IO BS.ByteString + sessionId <- case eitherDecode sessionResponse of + Left err -> assertFailure err + Right (CreateSessionAtHeadResponse reqId' sid) -> do + assertEqual "request ID round-trip" reqId' reqId + pure sid + Right _other -> assertFailure ("expected session response but got: " <> show sessionResponse) + -- send tutd message + reqIdB <- RequestId <$> nextRandom + let tutdMsg = encode (ExecuteTutorialDRequest reqIdB sessionId jsonOnlyPresentation (TutorialDText ":showexpr true")) + WS.sendTextData conn tutdMsg discardPromptInfo conn --receive relation response response <- WS.receiveData conn :: IO BS.ByteString - let decoded = decode response :: Maybe (M.Map Text (M.Map Text Relation)) + let decoded = decode @Response response case decoded of Nothing -> assertFailure "failed to decode" - Just decoded' -> do - assertEqual "round-trip true relation" ((decoded' M.! "displayrelation") M.! "json") relationTrue - WS.sendClose conn ("test close" :: Text) + Just (RelationResponse _ trueRel _) -> do + assertEqual "round-trip true relation" trueRel relationTrue + WS.sendClose conn ("" :: Text) + Just _other -> assertFailure ("unexpected response: " <> show response)