project-m36 1.0.1 → 1.0.2

raw patch · 5 files changed

+396/−106 lines, 5 filesdep ~curryer-rpcdep ~streamlyPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: curryer-rpc, streamly

API changes (from Hackage documentation)

Files

• Changelog.markdown +6/−0
• project-m36.cabal +63/−3
• src/bin/ProjectM36/Server/RemoteCallTypes/Json.hs +8/−0
• src/bin/ProjectM36/Server/WebSocket.hs +282/−85
• test/Server/WebSocket.hs +37/−18

@@ -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

@@ -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

@@ -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

@@ -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 ]

@@ -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)