From f08c4679cc6ef497f64728d66df78d0290fa874f Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Mon, 12 Oct 2020 18:57:14 +0100 Subject: [PATCH] add ReaderT, unliftio --- package.yaml | 5 ++- src/EnvStm.hs | 14 +++++--- src/Main.hs | 92 +++++++++++++++++++++--------------------------- src/Transport.hs | 57 ++++++++++++------------------ 4 files changed, 76 insertions(+), 92 deletions(-) diff --git a/package.yaml b/package.yaml index a469396cb..de7cce1e7 100644 --- a/package.yaml +++ b/package.yaml @@ -13,13 +13,16 @@ extra-source-files: dependencies: - base >= 4.7 && < 5 - - async + # - async - bytestring - containers + - mtl - network - polysemy - singletons - stm + - unliftio-core + - unliftio executables: simplex-messaging: diff --git a/src/EnvStm.hs b/src/EnvStm.hs index 5e5ef7012..6b8965797 100644 --- a/src/EnvStm.hs +++ b/src/EnvStm.hs @@ -1,17 +1,18 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE NamedFieldPuns #-} -module EnvStm where +module EnvSTM where import Control.Concurrent.STM import qualified Data.Map as M import qualified Data.Set as S +import Network.Socket (ServiceName) import Store import System.IO import Transmission data Env = Env - { port :: String, + { tcpPort :: ServiceName, server :: TVar Server, connStore :: TVar ConnStoreData } @@ -30,8 +31,13 @@ data Client = Client newServer :: STM (TVar Server) newServer = newTVar $ Server {clients = S.empty, connections = M.empty} +newClient :: Handle -> STM Client +newClient h = do + c <- newTChan + return Client {handle = h, connections = S.empty, channel = c} + newEnv :: String -> STM Env -newEnv port = do +newEnv tcpPort = do srv <- newServer st <- newConnStore - return Env {port, server = srv, connStore = st} + return Env {tcpPort, server = srv, connStore = st} diff --git a/src/Main.hs b/src/Main.hs index 232e3764f..ce5dd65c8 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -5,65 +5,54 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} module Main where -import Control.Concurrent -import Control.Concurrent.Async -import Control.Concurrent.STM -import qualified Control.Exception as E import Control.Monad -import Data.Function ((&)) -import Data.Map (Map) -import qualified Data.Map as M -import Data.Set (Set) -import qualified Data.Set as S -import EnvStm +import Control.Monad.IO.Unlift +import Control.Monad.Reader +import EnvSTM import Network.Socket -import Polysemy -import Polysemy.Embed -import Polysemy.Resource +-- import Polysemy import Store -import System.IO import Transmission import Transport +import UnliftIO.Async +import UnliftIO.Concurrent +import qualified UnliftIO.Exception as E +import UnliftIO.IO +import UnliftIO.STM -newClient :: Handle -> IO Client -newClient h = do - c <- newTChanIO @SomeSigned - return Client {handle = h, connections = S.empty, channel = c} +port :: ServiceName +port = "5223" main :: IO () main = do - server <- atomically newServer - putStrLn $ "Listening on port " ++ port' - runTCPServer port' $ runClient server + env <- atomically $ newEnv port + putStrLn $ "Listening on port " ++ port + runReaderT (runTCPServer runClient) env -port' :: String -port' = "5223" - -runTCPServer :: ServiceName -> (Handle -> IO ()) -> IO () -runTCPServer port server = - E.bracket (startTCPServer port) close $ \sock -> forever $ do +runTCPServer :: (MonadReader Env m, MonadUnliftIO m) => (Handle -> m ()) -> m () +runTCPServer server = + E.bracket startTCPServer (liftIO . close) $ \sock -> forever $ do h <- acceptTCPConn sock - hPutStrLn h "Welcome\r" + putLn h "Welcome" forkFinally (server h) (const $ hClose h) -runClient :: TVar Server -> Handle -> IO () -runClient server h = do - c <- newClient h - void $ race (client server c) (receive c) +runClient :: MonadUnliftIO m => Handle -> m () +runClient h = do + c <- atomically $ newClient h + void $ race (client c) (receive c) -receive :: Client -> IO () +receive :: MonadIO m => Client -> m () receive Client {handle, channel} = forever $ do - signature <- hGetLine handle - connId <- hGetLine handle - command <- hGetLine handle + signature <- getLn handle + connId <- getLn handle + command <- getLn handle cmdOrError <- parseVerifyTransmission signature connId command atomically $ writeTChan channel cmdOrError -parseVerifyTransmission :: String -> String -> String -> IO SomeSigned +parseVerifyTransmission :: Monad m => String -> String -> String -> m SomeSigned parseVerifyTransmission _ connId command = do return (Just connId, parseCommand command) @@ -76,27 +65,26 @@ parseCommand command = case words command of ["SUSPEND"] -> rCmd SUSPEND ["DELETE"] -> rCmd DELETE ["SEND", msgBody] -> SomeCom SSender $ SEND msgBody - "CREATE" : _ -> error SYNTAX - "SUB" : _ -> error SYNTAX - "SECURE" : _ -> error SYNTAX - "DELMSG" : _ -> error SYNTAX - "SUSPEND" : _ -> error SYNTAX - "DELETE" : _ -> error SYNTAX - "SEND" : _ -> error SYNTAX - _ -> error CMD + "CREATE" : _ -> err SYNTAX + "SUB" : _ -> err SYNTAX + "SECURE" : _ -> err SYNTAX + "DELMSG" : _ -> err SYNTAX + "SUSPEND" : _ -> err SYNTAX + "DELETE" : _ -> err SYNTAX + "SEND" : _ -> err SYNTAX + _ -> err CMD where rCmd = SomeCom SRecipient - error t = SomeCom SBroker $ ERROR t + err t = SomeCom SBroker $ ERROR t -client :: TVar Server -> Client -> IO () -client server Client {handle, channel} = loop +client :: MonadIO m => Client -> m () +client Client {handle, channel} = loop where - loop = do + loop = forever $ do (_, cmdOrErr) <- atomically $ readTChan channel let response = case cmdOrErr of SomeCom SRecipient _ -> "OK" SomeCom SSender _ -> "OK" SomeCom SBroker (ERROR t) -> "ERROR " ++ show t _ -> "ERROR INTERNAL" - hPutStrLn handle response - loop + putLn handle response diff --git a/src/Transport.hs b/src/Transport.hs index eabd9ab8d..9748d9a4b 100644 --- a/src/Transport.hs +++ b/src/Transport.hs @@ -1,42 +1,28 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeOperators #-} module Transport where +import Control.Monad.IO.Class +import Control.Monad.Reader +import EnvSTM import Network.Socket -import Polysemy -import Polysemy.Reader -import Polysemy.Resource import System.IO -data Transport h m a where - TReadLn :: h -> Transport h m String - TWriteLn :: h -> String -> Transport h m () +startTCPServer :: (MonadReader Env m, MonadIO m) => m Socket +startTCPServer = do + port <- asks tcpPort + liftIO . withSocketsDo $ do + let hints = defaultHints {addrFlags = [AI_PASSIVE], addrSocketType = Stream} + addr <- head <$> getAddrInfo (Just hints) Nothing (Just port) + sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) + setSocketOption sock ReuseAddr 1 + withFdSocket sock setCloseOnExecIfNeeded + bind sock $ addrAddress addr + listen sock 1024 + return sock -makeSem ''Transport - -type TCPTransport = Transport Handle - -startTCPServer :: String -> IO Socket -startTCPServer port = withSocketsDo $ do - let hints = defaultHints {addrFlags = [AI_PASSIVE], addrSocketType = Stream} - addr <- head <$> getAddrInfo (Just hints) Nothing (Just port) - sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) - setSocketOption sock ReuseAddr 1 - withFdSocket sock setCloseOnExecIfNeeded - bind sock $ addrAddress addr - listen sock 1024 - return sock - -acceptTCPConn :: Socket -> IO Handle -acceptTCPConn sock = do +acceptTCPConn :: MonadIO m => Socket -> m Handle +acceptTCPConn sock = liftIO $ do (conn, peer) <- accept sock putStrLn $ "Accepted connection from " ++ show peer h <- socketToHandle conn ReadWriteMode @@ -45,7 +31,8 @@ acceptTCPConn sock = do hSetBuffering h LineBuffering return h -runTCPTransportIO :: Member (Embed IO) r => Sem (TCPTransport ': r) a -> Sem r a -runTCPTransportIO = interpret $ \case - TReadLn h -> embed $ hGetLine h - TWriteLn h str -> embed $ hPutStr h $ str ++ "\r\n" +putLn :: MonadIO m => Handle -> String -> m () +putLn h = liftIO . hPutStrLn h + +getLn :: MonadIO m => Handle -> m String +getLn = liftIO . hGetLine