simplex-chat server & JavaScript/TypeScript SDK/client (#539)

* simplex-chat server

* typescript types for chat commands and command serialization

* typescript ChatResponse type

* more types

* more types

* websocket chat client

* aligb ts/haskell types

* chat server & TS client via websockets - it works

* TS chat client test

* TS chat client test

* update test

* more api functions

* more api methods, refactor, readme

* squaring chat bot example, fixes

* update readme

* remove console.log

* npm version 0.1.0

apps/simplex-chat/Main.hs

@@ -3,6 +3,7 @@
 module Main where
 
 import Control.Concurrent (threadDelay)
+import Server
 import Simplex.Chat.Controller (versionNumber)
 import Simplex.Chat.Core
 import Simplex.Chat.Options
@@ -14,12 +15,15 @@ import System.Terminal (withTerminal)
 main :: IO ()
 main = do
   appDir <- getAppUserDataDirectory "simplex"
-  opts@ChatOpts {chatCmd} <- getChatOpts appDir "simplex_v1"
+  opts@ChatOpts {chatCmd, chatServerPort} <- getChatOpts appDir "simplex_v1"
   if null chatCmd
-    then do
-      welcome opts
-      t <- withTerminal pure
-      simplexChatTerminal terminalChatConfig opts t
+    then case chatServerPort of
+      Just chatPort ->
+        simplexChatServer defaultChatServerConfig {chatPort} terminalChatConfig opts
+      _ -> do
+        welcome opts
+        t <- withTerminal pure
+        simplexChatTerminal terminalChatConfig opts t
     else simplexChatCore terminalChatConfig opts Nothing $ \_ cc -> do
       r <- sendChatCmd cc chatCmd
       putStrLn $ serializeChatResponse r

apps/simplex-chat/Server.hs

@@ -0,0 +1,105 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Server where
+
+import Control.Monad.Except
+import Control.Monad.Reader
+import Data.Aeson (FromJSON, ToJSON)
+import qualified Data.Aeson as J
+import Data.Text (Text)
+import Data.Text.Encoding (encodeUtf8)
+import GHC.Generics (Generic)
+import Network.Socket
+import qualified Network.WebSockets as WS
+import Numeric.Natural (Natural)
+import Simplex.Chat
+import Simplex.Chat.Controller
+import Simplex.Chat.Core
+import Simplex.Chat.Options
+import Simplex.Messaging.Transport.Server (runTCPServer)
+import Simplex.Messaging.Util (raceAny_)
+import UnliftIO.Exception
+import UnliftIO.STM
+
+simplexChatServer :: ChatServerConfig -> ChatConfig -> ChatOpts -> IO ()
+simplexChatServer srvCfg cfg opts =
+  simplexChatCore cfg opts Nothing . const $ runChatServer srvCfg
+
+data ChatServerConfig = ChatServerConfig
+  { chatPort :: ServiceName,
+    clientQSize :: Natural
+  }
+
+defaultChatServerConfig :: ChatServerConfig
+defaultChatServerConfig =
+  ChatServerConfig
+    { chatPort = "5225",
+      clientQSize = 1
+    }
+
+data ChatSrvRequest = ChatSrvRequest {corrId :: Text, cmd :: Text}
+  deriving (Generic, FromJSON)
+
+data ChatSrvResponse = ChatSrvResponse {corrId :: Maybe Text, resp :: ChatResponse}
+  deriving (Generic)
+
+instance ToJSON ChatSrvResponse where
+  toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
+  toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True}
+
+data ChatClient = ChatClient
+  { rcvQ :: TBQueue (Text, ChatCommand),
+    sndQ :: TBQueue ChatSrvResponse
+  }
+
+newChatServerClient :: Natural -> STM ChatClient
+newChatServerClient qSize = do
+  rcvQ <- newTBQueue qSize
+  sndQ <- newTBQueue qSize
+  pure ChatClient {rcvQ, sndQ}
+
+runChatServer :: ChatServerConfig -> ChatController -> IO ()
+runChatServer ChatServerConfig {chatPort, clientQSize} cc = do
+  started <- newEmptyTMVarIO
+  runTCPServer started chatPort $ \sock -> do
+    ws <- liftIO $ getConnection sock
+    c <- atomically $ newChatServerClient clientQSize
+    putStrLn "client connected"
+    raceAny_ [send ws c, client c, output c, receive ws c]
+      `finally` clientDisconnected c
+  where
+    getConnection sock = WS.makePendingConnection sock WS.defaultConnectionOptions >>= WS.acceptRequest
+    send ws ChatClient {sndQ} =
+      forever $
+        atomically (readTBQueue sndQ) >>= WS.sendTextData ws . J.encode
+    client ChatClient {rcvQ, sndQ} = forever $ do
+      atomically (readTBQueue rcvQ)
+        >>= processCommand
+        >>= atomically . writeTBQueue sndQ
+    output ChatClient {sndQ} = forever $ do
+      (_, resp) <- atomically . readTBQueue $ outputQ cc
+      atomically $ writeTBQueue sndQ ChatSrvResponse {corrId = Nothing, resp}
+    receive ws ChatClient {rcvQ, sndQ} = forever $ do
+      s <- WS.receiveData ws
+      case J.decodeStrict' s of
+        Just ChatSrvRequest {corrId, cmd} -> do
+          putStrLn $ "received command " <> show corrId <> " : " <> show cmd
+          case parseChatCommand $ encodeUtf8 cmd of
+            Right command -> atomically $ writeTBQueue rcvQ (corrId, command)
+            Left e -> sendError (Just corrId) e
+        Nothing -> sendError Nothing "invalid request"
+      where
+        sendError corrId e = atomically $ writeTBQueue sndQ ChatSrvResponse {corrId, resp = chatCmdError e}
+    processCommand (corrId, cmd) =
+      runReaderT (runExceptT $ processChatCommand cmd) cc >>= \case
+        Right resp -> response resp
+        Left e -> response $ CRChatCmdError e
+      where
+        response resp = pure ChatSrvResponse {corrId = Just corrId, resp}
+    clientDisconnected _ = pure ()