From 130b556c56fe795954a7d8b1f4034d7ee5bd58a5 Mon Sep 17 00:00:00 2001 From: Abhinav Sarkar Date: Thu, 10 Sep 2015 13:20:55 +0530 Subject: [PATCH] Moves client channels to TChan --- link.cabal | 3 +- src/Link/Client.hs | 76 ++++++++++++++++++++------------------------ src/Link/Protocol.hs | 10 +++--- src/Link/Server.hs | 19 ++++++----- src/Link/Types.hs | 14 +++++--- 5 files changed, 62 insertions(+), 60 deletions(-) diff --git a/link.cabal b/link.cabal index dc543a1..8adba40 100644 --- a/link.cabal +++ b/link.cabal @@ -25,7 +25,8 @@ library build-depends: base >= 4.7 && < 5, network >= 2.6 && < 2.7, containers >= 0.5 && < 0.6, - time >= 1.4 && < 1.6 + time >= 1.4 && < 1.6, + stm >= 2.4 && < 2.5 default-language: Haskell2010 executable link-exe diff --git a/src/Link/Client.hs b/src/Link/Client.hs index dd3187b..02e4971 100644 --- a/src/Link/Client.hs +++ b/src/Link/Client.hs @@ -1,12 +1,13 @@ module Link.Client where -import Control.Concurrent hiding (forkFinally) -import Control.Exception hiding (handle) -import Control.Monad (void) -import Data.Time (getCurrentTime, diffUTCTime) -import System.IO (hGetLine) -import System.Timeout (timeout) -import Text.Printf (printf) +import Control.Concurrent.STM (STM, writeTChan, readTChan, atomically, orElse) +import Control.Concurrent hiding (forkFinally) +import Control.Exception hiding (handle) +import Control.Monad (void, forever) +import Data.Time (getCurrentTime, diffUTCTime) +import System.IO (hGetLine) +import System.Timeout (timeout) +import Text.Printf (printf) import qualified Data.Map.Strict as Map @@ -19,38 +20,34 @@ forkFinally action fun = mask $ \restore -> forkIO (do r <- try (restore action); fun r) -race :: IO a -> IO b -> IO (Either a b) -race ioa iob = do - m <- newEmptyMVar - bracket (forkFinally (fmap Left ioa) (putMVar m)) killThread $ \_ -> - bracket (forkFinally (fmap Right iob) (putMVar m)) killThread $ \_ -> do - r <- readMVar m - case r of - Left e -> throwIO e - Right a -> return a +sendMessage :: Client -> Message -> STM () +sendMessage Client {..} = writeTChan clientChan -sendMessage :: Client -> Message -> IO () -sendMessage Client {..} = writeChan clientChan +sendMessageIO :: Client -> Message -> IO () +sendMessageIO client = atomically . sendMessage client sendResponse :: Client -> Message -> IO () sendResponse Client {..} = printToHandle clientHandle . formatMessage runClient :: Server -> Client -> IO () runClient Server {..} client@Client {..} = do - clientAlive <- newMVar True - pingThread <- forkIO $ ping clientAlive - run clientAlive `finally` killThread pingThread + clientAlive <- newMVar True + pingThread <- forkIO $ ping clientAlive `finally` killClient clientAlive + commandThread <- forkIO $ readCommands `finally` killClient clientAlive + run clientAlive `finally` (killThread pingThread >> killThread commandThread) where pingDelay = 120 pingDelayMicros = pingDelay * 1000 * 1000 + killClient clientAlive = void $ swapMVar clientAlive False + ping clientAlive = do - sendMessage client Ping + sendMessageIO client Ping threadDelay pingDelayMicros now <- getCurrentTime pongTime <- readMVar clientPongTime if diffUTCTime now pongTime > fromIntegral pingDelay - then void $ swapMVar clientAlive False + then killClient clientAlive else ping clientAlive run clientAlive = do @@ -58,32 +55,29 @@ runClient Server {..} client@Client {..} = do if not alive then printf "Closing connection: %s\n" (userName clientUser) else do - r <- try . timeout pingDelayMicros $ race readCommand readMessage + r <- try . timeout pingDelayMicros . atomically . readTChan $ clientChan case r of Left (e :: SomeException) -> printf "Exception: %s\n" (show e) - Right g -> case g of - Nothing -> run clientAlive - Just cm -> do - case cm of - Left mcommand -> case mcommand of - Nothing -> printf "Could not parse command\n" - Just command -> handleCommand command clientAlive - Right message -> sendResponse client message - run clientAlive + Right g -> do + case g of + Nothing -> return () + Just message -> handleMessage message clientAlive + run clientAlive - readCommand = do + readCommands = forever $ do command <- hGetLine clientHandle printf "<%s>: %s\n" (userName clientUser) command - return $ parseCommand command + case parseCommand command of + Nothing -> printf "Could not parse command: %s\n" command + Just c -> sendMessageIO client c - readMessage = readChan clientChan - - handleCommand (Msg user msg) _ = + handleMessage (Msg user msg) _ = withMVar serverUsers $ \clientMap -> case Map.lookup user clientMap of Nothing -> sendResponse client $ NoSuchUser (userName user) - Just client' -> sendMessage client' $ Msg clientUser msg - handleCommand Pong _ = do + Just client' -> sendMessageIO client' $ MsgReply clientUser msg + handleMessage Pong _ = do now <- getCurrentTime void $ swapMVar clientPongTime now - handleCommand Quit clientAlive = void $ swapMVar clientAlive False + handleMessage Quit clientAlive = killClient clientAlive + handleMessage message _ = sendResponse client message diff --git a/src/Link/Protocol.hs b/src/Link/Protocol.hs index e7dbdf2..a2eab8f 100644 --- a/src/Link/Protocol.hs +++ b/src/Link/Protocol.hs @@ -12,8 +12,8 @@ parseCommand command = case words command of _ -> Nothing formatMessage :: Message -> String -formatMessage (Msg user msg) = printf "MSG %s %s" (userName user) msg -formatMessage (NameInUse name) = printf "NAMEINUSE %s" name -formatMessage (Connected name) = printf "CONNECTED %s" name -formatMessage Ping = "PING" -formatMessage (NoSuchUser name) = printf "NOSUCHUSER %s" name +formatMessage (MsgReply user msg) = printf "MSG %s %s" (userName user) msg +formatMessage (NameInUse name) = printf "NAMEINUSE %s" name +formatMessage (Connected name) = printf "CONNECTED %s" name +formatMessage Ping = "PING" +formatMessage (NoSuchUser name) = printf "NOSUCHUSER %s" name diff --git a/src/Link/Server.hs b/src/Link/Server.hs index b713826..c3405a5 100644 --- a/src/Link/Server.hs +++ b/src/Link/Server.hs @@ -1,13 +1,14 @@ module Link.Server where import Control.Concurrent -import Control.Exception hiding (handle) -import Control.Monad (forever) -import Data.Time (getCurrentTime) -import Network (withSocketsDo, listenOn, accept, PortID(..)) -import System.IO (hClose, hSetNewlineMode, hSetBuffering, BufferMode(..), - universalNewlineMode, hGetLine, Handle, stdout) -import Text.Printf (printf) +import Control.Concurrent.STM (newTChanIO) +import Control.Exception hiding (handle) +import Control.Monad (forever) +import Data.Time (getCurrentTime) +import Network (withSocketsDo, listenOn, accept, PortID(..)) +import System.IO (hClose, hSetNewlineMode, hSetBuffering, BufferMode(..), + universalNewlineMode, hGetLine, Handle, stdout) +import Text.Printf (printf) import qualified Data.Map.Strict as Map @@ -19,8 +20,10 @@ import Link.Util runServer :: Int -> IO () runServer port = withSocketsDo $ do hSetBuffering stdout LineBuffering + serverUsers <- newMVar Map.empty let server = Server serverUsers + sock <- listenOn . PortNumber . fromIntegral $ port printf "Listening on port %d\n" port forever $ do @@ -55,7 +58,7 @@ checkAddClient Server {..} user@User {..} handle = if Map.member user clientMap then return (clientMap, Nothing) else do - clientChan <- newChan + clientChan <- newTChanIO now <- getCurrentTime clientPongTime <- newMVar now let client = Client user handle clientChan clientPongTime diff --git a/src/Link/Types.hs b/src/Link/Types.hs index dd186d6..7ed8103 100644 --- a/src/Link/Types.hs +++ b/src/Link/Types.hs @@ -1,12 +1,15 @@ module Link.Types where -import Control.Concurrent (MVar, Chan) -import Data.Time (UTCTime) -import System.IO (Handle) +import Control.Concurrent (MVar) +import Control.Concurrent.STM (TVar, TChan) +import Data.Time (UTCTime) +import System.IO (Handle) import qualified Data.Map as Map +import qualified Data.Set as Set type UserName = String +type RoomName = String data User = User { userName :: !UserName } deriving (Show, Eq, Ord) @@ -14,7 +17,7 @@ data User = User { userName :: !UserName } data Client = Client { clientUser :: !User , clientHandle :: !Handle - , clientChan :: !(Chan Message) + , clientChan :: !(TChan Message) , clientPongTime :: MVar UTCTime } @@ -25,8 +28,9 @@ data Server = Server { data Message = NameInUse UserName | Connected UserName | Ping + | MsgReply User String + | NoSuchUser UserName | Pong | Msg User String - | NoSuchUser UserName | Quit deriving (Show, Eq)