diff --git a/apps/dog-food/ChatOptions.hs b/apps/dog-food/ChatOptions.hs index 8d0a0560f4..7c94bff992 100644 --- a/apps/dog-food/ChatOptions.hs +++ b/apps/dog-food/ChatOptions.hs @@ -3,7 +3,10 @@ module ChatOptions (getChatOpts, ChatOpts (..)) where +import qualified Data.Attoparsec.ByteString.Char8 as A import qualified Data.ByteString.Char8 as B +import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as L import Options.Applicative import Simplex.Messaging.Agent.Transmission (SMPServer (..), smpServerP) import Simplex.Messaging.Parsers (parseAll) @@ -11,8 +14,8 @@ import System.FilePath (combine) import Types data ChatOpts = ChatOpts - { dbFileName :: String, - smpServer :: SMPServer, + { dbFile :: String, + smpServers :: NonEmpty SMPServer, termMode :: TermMode } @@ -31,8 +34,8 @@ chatOpts appDir = ( long "server" <> short 's' <> metavar "SERVER" - <> help "SMP server to use (smp1.simplex.im:5223#pLdiGvm0jD1CMblnov6Edd/391OrYsShw+RgdfR0ChA=)" - <> value (SMPServer "smp1.simplex.im" (Just "5223") (Just "pLdiGvm0jD1CMblnov6Edd/391OrYsShw+RgdfR0ChA=")) + <> help "SMP server(s) to use (smp1.simplex.im#pLdiGvm0jD1CMblnov6Edd/391OrYsShw+RgdfR0ChA=)" + <> value (L.fromList ["smp1.simplex.im#pLdiGvm0jD1CMblnov6Edd/391OrYsShw+RgdfR0ChA="]) ) <*> option parseTermMode @@ -45,8 +48,10 @@ chatOpts appDir = where defaultDbFilePath = combine appDir "smp-chat.db" -parseSMPServer :: ReadM SMPServer -parseSMPServer = eitherReader $ parseAll smpServerP . B.pack +parseSMPServer :: ReadM (NonEmpty SMPServer) +parseSMPServer = eitherReader $ parseAll servers . B.pack + where + servers = L.fromList <$> smpServerP `A.sepBy1` A.char ',' parseTermMode :: ReadM TermMode parseTermMode = maybeReader $ \case diff --git a/apps/dog-food/ChatTerminal.hs b/apps/dog-food/ChatTerminal.hs index cb61daddbb..e2780abfa5 100644 --- a/apps/dog-food/ChatTerminal.hs +++ b/apps/dog-food/ChatTerminal.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} diff --git a/apps/dog-food/Main.hs b/apps/dog-food/Main.hs index 70549ff05e..e3871afab1 100644 --- a/apps/dog-food/Main.hs +++ b/apps/dog-food/Main.hs @@ -44,7 +44,8 @@ import Types cfg :: AgentConfig cfg = AgentConfig - { tcpPort = undefined, -- TODO maybe take it out of config + { tcpPort = undefined, -- agent does not listen to TCP + smpServers = undefined, -- filled in from options rsaKeySize = 2048 `div` 8, connIdBytes = 12, tbqSize = 16, @@ -57,8 +58,7 @@ logCfg = LogConfig {lc_file = Nothing, lc_stderr = True} data ChatClient = ChatClient { inQ :: TBQueue ChatCommand, - outQ :: TBQueue ChatResponse, - smpServer :: SMPServer + outQ :: TBQueue ChatResponse } -- | GroupMessage ChatGroup ByteString @@ -199,20 +199,20 @@ markdownInfo = main :: IO () main = do - opts@ChatOpts {dbFileName, smpServer, termMode} <- welcomeGetOpts - t <- getChatClient smpServer + opts@ChatOpts {dbFile, smpServers, termMode} <- welcomeGetOpts + t <- atomically $ newChatClient (tbqSize cfg) ct <- newChatTerminal (tbqSize cfg) termMode -- setLogLevel LogInfo -- LogError -- withGlobalLogging logCfg $ do - env <- newSMPAgentEnv cfg {dbFile = dbFileName} + env <- newSMPAgentEnv cfg {dbFile, smpServers} dogFoodChat t ct env opts welcomeGetOpts :: IO ChatOpts welcomeGetOpts = do appDir <- getAppUserDataDirectory "simplex" - opts@ChatOpts {dbFileName} <- getChatOpts appDir + opts@ChatOpts {dbFile} <- getChatOpts appDir putStrLn "SimpleX chat prototype v0.3.0" - putStrLn $ "db: " <> dbFileName + putStrLn $ "db: " <> dbFile putStrLn "type \"/help\" or \"/h\" for usage info" pure opts @@ -229,14 +229,11 @@ dogFoodChat t ct env opts = do chatTerminal ct ] -getChatClient :: SMPServer -> IO ChatClient -getChatClient srv = atomically $ newChatClient (tbqSize cfg) srv - -newChatClient :: Natural -> SMPServer -> STM ChatClient -newChatClient qSize smpServer = do +newChatClient :: Natural -> STM ChatClient +newChatClient qSize = do inQ <- newTBQueue qSize outQ <- newTBQueue qSize - return ChatClient {inQ, outQ, smpServer} + return ChatClient {inQ, outQ} receiveFromChatTerm :: ChatClient -> ChatTerminal -> IO () receiveFromChatTerm t ct = forever $ do @@ -259,7 +256,7 @@ sendToChatTerm ChatClient {outQ} ChatTerminal {outputQ} opts localTz = forever $ atomically . writeTBQueue outputQ $ serializeChatResponse opts localTz currentTime resp sendToAgent :: ChatClient -> ChatTerminal -> AgentClient -> IO () -sendToAgent ChatClient {inQ, smpServer} ct AgentClient {rcvQ} = do +sendToAgent ChatClient {inQ} ct AgentClient {rcvQ} = do atomically $ writeTBQueue rcvQ ("1", "", SUBALL) -- hack for subscribing to all forever . atomically $ do cmd <- readTBQueue inQ @@ -273,8 +270,8 @@ sendToAgent ChatClient {inQ, smpServer} ct AgentClient {rcvQ} = do _ -> pure () agentTransmission :: ChatCommand -> Maybe (ATransmission 'Client) agentTransmission = \case - AddConnection a -> transmission a $ NEW smpServer - Connect a qInfo -> transmission a $ JOIN qInfo $ ReplyVia smpServer + AddConnection a -> transmission a NEW + Connect a qInfo -> transmission a $ JOIN qInfo $ ReplyMode On DeleteConnection a -> transmission a DEL SendMessage a msg -> transmission a $ SEND msg ChatHelp -> Nothing diff --git a/stack.yaml b/stack.yaml index 3c36647e63..2931364f9b 100644 --- a/stack.yaml +++ b/stack.yaml @@ -40,8 +40,9 @@ extra-deps: - simple-logger-0.1.0@sha256:be8ede4bd251a9cac776533bae7fb643369ebd826eb948a9a18df1a8dd252ff8,1079 - sqlite-simple-0.4.18.0@sha256:3ceea56375c0a3590c814e411a4eb86943f8d31b93b110ca159c90689b6b39e5,3002 - terminal-0.2.0.0@sha256:de6770ecaae3197c66ac1f0db5a80cf5a5b1d3b64a66a05b50f442de5ad39570,2977 + # - ../simplexmq - github: simplex-chat/simplexmq - commit: 2b0950e78e390b41cf4064818534d7791aa293ae + commit: 4b9ebbbab2fb8912cf08a289fa73050ec86ddf51 # - network-run-0.2.4@sha256:7dbb06def522dab413bce4a46af476820bffdff2071974736b06f52f4ab57c96,885 # - git: https://github.com/commercialhaskell/stack.git # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a