From 5e5baeab06fe1dc45244364f75593d38cd9a6398 Mon Sep 17 00:00:00 2001 From: Abhinav Sarkar Date: Thu, 10 Sep 2015 01:05:12 +0530 Subject: [PATCH] Spilts server into more modules. --- src/Link/Client.hs | 59 ++++++++++++++++++++++++++++++++++++++++++++++ src/Link/Server.hs | 55 +++++------------------------------------- src/Link/Util.hs | 7 ++++++ 3 files changed, 72 insertions(+), 49 deletions(-) create mode 100644 src/Link/Client.hs create mode 100644 src/Link/Util.hs diff --git a/src/Link/Client.hs b/src/Link/Client.hs new file mode 100644 index 0000000..5116674 --- /dev/null +++ b/src/Link/Client.hs @@ -0,0 +1,59 @@ +module Link.Client where + +import Control.Exception hiding (handle) +import Control.Concurrent hiding (forkFinally) +import Control.Monad (forever) +import System.IO (hGetLine) +import Text.Printf (printf) + +import qualified Data.Map.Strict as Map + +import Link.Protocol +import Link.Types +import Link.Util + +forkFinally :: IO a -> (Either SomeException a -> IO ()) -> IO ThreadId +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)) cancel $ \_ -> + bracket (forkFinally (fmap Right iob) (putMVar m)) cancel $ \_ -> do + r <- readMVar m + case r of + Left e -> throwIO e + Right a -> return a + where + cancel t = throwTo t ThreadKilled + +sendMessage :: Message -> Client -> IO () +sendMessage message Client {..} = writeChan clientChan message + +runClient :: Server -> Client -> IO () +runClient Server {..} Client {..} = forever $ do + r <- try $ race readCommand readMessage + case r of + Left (e :: SomeException) -> printf "Exception: %s\n" (show e) + Right cm -> case cm of + Left mcommand -> case mcommand of + Nothing -> printf "Could not parse command\n" + Just command -> handleCommand command + Right message -> handleMessage message + where + readCommand = do + command <- hGetLine clientHandle + printf "<%s>: %s\n" (userName clientUser) command + return $ parseCommand command + + readMessage = readChan clientChan + + handleCommand (PrivMsg user msg) = + withMVar serverUsers $ \clientMap -> + case Map.lookup user clientMap of + Nothing -> printf "No such user: %s\n" (userName user) + Just client -> sendMessage (PrivMsg clientUser msg) client + + handleMessage = printToHandle clientHandle . formatMessage diff --git a/src/Link/Server.hs b/src/Link/Server.hs index b5e14dc..29578d5 100644 --- a/src/Link/Server.hs +++ b/src/Link/Server.hs @@ -1,18 +1,19 @@ module Link.Server where -import Control.Exception (finally, bracket, throwIO, try, SomeException, - AsyncException(ThreadKilled)) -import Control.Concurrent +import Control.Exception hiding (handle) +import Control.Concurrent hiding (forkFinally) import Control.Monad (forever) import Network (withSocketsDo, listenOn, accept, PortID(..)) import System.IO (hClose, hSetNewlineMode, hSetBuffering, BufferMode(..), universalNewlineMode, hGetLine, Handle, stdout) -import Text.Printf (printf, hPrintf) +import Text.Printf (printf) import qualified Data.Map.Strict as Map +import Link.Client import Link.Protocol import Link.Types +import Link.Util runServer :: Int -> IO () runServer port = withSocketsDo $ do @@ -24,10 +25,7 @@ runServer port = withSocketsDo $ do forever $ do (handle, host, port') <- accept sock printf "Accepted connection from %s: %s\n" host (show port') - forkFinally (connectClient server handle) (\_ -> hClose handle) - -printToHandle :: Handle -> String -> IO () -printToHandle handle str = hPrintf handle "%s\n" str + forkIO (connectClient server handle) `finally` (hClose handle) connectClient :: Server -> Handle -> IO () connectClient server handle = do @@ -61,47 +59,6 @@ checkAddClient Server {..} user@User {..} handle = printf "New user connected: %s\n" userName return (Map.insert user client clientMap, Just client) -race :: IO a -> IO b -> IO (Either a b) -race ioa iob = do - m <- newEmptyMVar - bracket (forkFinally (fmap Left ioa) (putMVar m)) cancel $ \_ -> - bracket (forkFinally (fmap Right iob) (putMVar m)) cancel $ \_ -> do - r <- readMVar m - case r of - Left e -> throwIO e - Right a -> return a - where - cancel t = throwTo t ThreadKilled - -sendMessage :: Message -> Client -> IO () -sendMessage message Client {..} = writeChan clientChan message - -runClient :: Server -> Client -> IO () -runClient Server {..} Client {..} = forever $ do - r <- try $ race readCommand readMessage - case r of - Left (e :: SomeException) -> printf "Exception: %s\n" (show e) - Right cm -> case cm of - Left mcommand -> case mcommand of - Nothing -> printf "Could not parse command\n" - Just command -> handleCommand command - Right message -> handleMessage message - where - readCommand = do - command <- hGetLine clientHandle - printf "<%s>: %s\n" (userName clientUser) command - return $ parseCommand command - - readMessage = readChan clientChan - - handleCommand (PrivMsg user msg) = - withMVar serverUsers $ \clientMap -> - case Map.lookup user clientMap of - Nothing -> printf "No such user: %s\n" (userName user) - Just client -> sendMessage (PrivMsg clientUser msg) client - - handleMessage = printToHandle clientHandle . formatMessage - removeClient :: Server -> User -> IO () removeClient Server {..} user = modifyMVar_ serverUsers $ \clientMap -> diff --git a/src/Link/Util.hs b/src/Link/Util.hs new file mode 100644 index 0000000..ba79468 --- /dev/null +++ b/src/Link/Util.hs @@ -0,0 +1,7 @@ +module Link.Util where + +import System.IO (Handle) +import Text.Printf (hPrintf) + +printToHandle :: Handle -> String -> IO () +printToHandle handle str = hPrintf handle "%s\n" str