diff --git a/src/Link/Protocol.hs b/src/Link/Protocol.hs index a31cac7..b5166ef 100644 --- a/src/Link/Protocol.hs +++ b/src/Link/Protocol.hs @@ -3,6 +3,6 @@ module Link.Protocol where import Link.Types parseCommand :: String -> Maybe Message -parseCommand command = case (words command) of +parseCommand command = case words command of "PRIVMSG" : userName : msg -> Just $ PrivMsg (User userName) (unwords msg) _ -> Nothing diff --git a/src/Link/Server.hs b/src/Link/Server.hs index 0856059..e2e06f4 100644 --- a/src/Link/Server.hs +++ b/src/Link/Server.hs @@ -1,8 +1,8 @@ module Link.Server where -import Control.Exception (finally) -import Control.Concurrent (forkFinally, newMVar, modifyMVar, modifyMVar_, newChan, - writeChan, withMVar) +import Control.Exception (finally, bracket, throwIO, try, SomeException, + AsyncException(ThreadKilled)) +import Control.Concurrent import Control.Monad (forever) import Network (withSocketsDo, listenOn, accept, PortID(..)) import System.IO (hClose, hSetNewlineMode, hSetBuffering, BufferMode(..), @@ -47,11 +47,8 @@ connectClient server handle = do Just client -> runClient server client `finally` removeClient server user -sendMessage :: Message -> Client -> IO () -sendMessage message Client {..} = writeChan clientChan message - checkAddClient :: Server -> User -> Handle -> IO (Maybe Client) -checkAddClient Server {..} user@User {..} handle = do +checkAddClient Server {..} user@User {..} handle = modifyMVar serverUsers $ \clientMap -> if Map.member user clientMap then return (clientMap, Nothing) @@ -61,19 +58,47 @@ checkAddClient Server {..} user@User {..} handle = do 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 - command <- hGetLine clientHandle - printf "<%s>: %s\n" (userName clientUser) command - case parseCommand command of - Nothing -> return () - Just com -> handleCommand com + 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 - handleCommand message@(PrivMsg user _) = + 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 message client + Just client -> sendMessage (PrivMsg clientUser msg) client + + handleMessage (PrivMsg user msg) = + hPrintf clientHandle "PRIVMSG %s %s\n" (userName user) msg removeClient :: Server -> User -> IO () removeClient Server {..} user =