mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2026-03-31 22:46:13 +00:00
b7860ad0e8
* 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
106 lines
3.7 KiB
Haskell
106 lines
3.7 KiB
Haskell
{-# 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 ()
|