diff --git a/src/Env/STM.hs b/src/Env/STM.hs index 3d3ed522f..f651ca295 100644 --- a/src/Env/STM.hs +++ b/src/Env/STM.hs @@ -15,9 +15,15 @@ import Numeric.Natural import Transmission import UnliftIO.STM -data Env = Env +data Config = Config { tcpPort :: ServiceName, queueSize :: Natural, + connIdBytes :: Int, + msgIdBytes :: Int + } + +data Env = Env + { config :: Config, server :: Server, connStore :: STMConnStore, msgStore :: STMMsgStore, @@ -48,10 +54,10 @@ newClient qSize = do sndQ <- newTBQueue qSize return Client {connections, rcvQ, sndQ} -newEnv :: (MonadUnliftIO m, MonadRandom m) => String -> Natural -> m Env -newEnv tcpPort queueSize = do - server <- atomically $ newServer queueSize +newEnv :: (MonadUnliftIO m, MonadRandom m) => Config -> m Env +newEnv config = do + server <- atomically $ newServer (queueSize config) connStore <- atomically newConnStore msgStore <- atomically newMsgStore idsDrg <- drgNew >>= newTVarIO - return Env {tcpPort, queueSize, server, connStore, msgStore, idsDrg} + return Env {config, server, connStore, msgStore, idsDrg} diff --git a/src/Main.hs b/src/Main.hs index 1c2f6f1e5..93356d90e 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,16 +1,18 @@ module Main where -import Network.Socket (ServiceName) -import Numeric.Natural +import Env.STM import Server (runSMPServer) -port :: ServiceName -port = "5223" - -queuePerClient :: Natural -queuePerClient = 16 +cfg :: Config +cfg = + Config + { tcpPort = "5223", + queueSize = 16, + connIdBytes = 12, + msgIdBytes = 6 + } main :: IO () main = do - putStrLn $ "Listening on port " ++ port - runSMPServer port queuePerClient + putStrLn $ "Listening on port " ++ tcpPort cfg + runSMPServer cfg diff --git a/src/Server.hs b/src/Server.hs index 16c0cf5a6..13d832778 100644 --- a/src/Server.hs +++ b/src/Server.hs @@ -25,8 +25,6 @@ import Data.Time.Clock import Env.STM import MsgStore import MsgStore.STM (MsgQueue) -import Network.Socket -import Numeric.Natural import Transmission import Transport import UnliftIO.Async @@ -34,15 +32,15 @@ import UnliftIO.Concurrent import UnliftIO.IO import UnliftIO.STM -runSMPServer :: (MonadRandom m, MonadUnliftIO m) => ServiceName -> Natural -> m () -runSMPServer port queueSize = do - env <- newEnv port queueSize +runSMPServer :: (MonadRandom m, MonadUnliftIO m) => Config -> m () +runSMPServer cfg@Config {tcpPort} = do + env <- newEnv cfg runReaderT smpServer env where smpServer :: (MonadUnliftIO m, MonadReader Env m) => m () smpServer = do s <- asks server - race_ (runTCPServer port runClient) (serverThread s) + race_ (runTCPServer tcpPort runClient) (serverThread s) serverThread :: MonadUnliftIO m => Server -> m () serverThread Server {subscribedQ, connections} = forever . atomically $ do @@ -56,7 +54,7 @@ runSMPServer port queueSize = do runClient :: (MonadUnliftIO m, MonadReader Env m) => Handle -> m () runClient h = do putLn h "Welcome to SMP" - q <- asks queueSize + q <- asks $ queueSize . config c <- atomically $ newClient q s <- asks server raceAny_ [send h c, client c s, receive h c] @@ -142,7 +140,9 @@ client clnt@Client {connections, rcvQ, sndQ} Server {subscribedQ} = void $ subscribeConn rId return $ IDS rId sId Left e -> return $ ERR e - getIds = liftM2 (,) (randomId 16) (randomId 16) + getIds = do + n <- asks $ connIdBytes . config + liftM2 (,) (randomId n) (randomId n) subscribeConn :: RecipientId -> m Signed subscribeConn rId = do @@ -166,14 +166,18 @@ client clnt@Client {connections, rcvQ, sndQ} Server {subscribedQ} = getConn st SSender sId >>= fmap (mkSigned sId) . either (return . ERR) storeMessage where + mkMessage :: m Message + mkMessage = do + msgId <- asks (msgIdBytes . config) >>= randomId + ts <- liftIO getCurrentTime + return $ Message {msgId, ts, msgBody} + storeMessage :: Connection -> m (Command 'Broker) storeMessage c = case status c of ConnActive -> do ms <- asks msgStore q <- getMsgQueue ms (recipientId c) - msgId <- randomId 8 - ts <- liftIO getCurrentTime - writeMsg q $ Message {msgId, ts, msgBody} + mkMessage >>= writeMsg q return OK ConnOff -> return $ ERR AUTH diff --git a/tests/SMPClient.hs b/tests/SMPClient.hs index 84ca3a3e7..57977edef 100644 --- a/tests/SMPClient.hs +++ b/tests/SMPClient.hs @@ -5,8 +5,8 @@ module SMPClient where import Control.Monad.IO.Unlift import Crypto.Random +import Env.STM import Network.Socket -import Numeric.Natural import Server import Transmission import Transport @@ -29,13 +29,19 @@ testPort = "5000" testHost :: HostName testHost = "localhost" -queueSize :: Natural -queueSize = 2 +cfg :: Config +cfg = + Config + { tcpPort = testPort, + queueSize = 1, + connIdBytes = 12, + msgIdBytes = 6 + } runSmpTest :: (MonadUnliftIO m, MonadRandom m) => (Handle -> m a) -> m a runSmpTest test = E.bracket - (forkIO $ runSMPServer testPort queueSize) + (forkIO $ runSMPServer cfg) (liftIO . killThread) \_ -> testSMPClient "localhost" testPort test