Some refactoring.

app/Main.hs

@@ -1,8 +1,9 @@
 module Main where
 
-import Link.Server
 import System.Environment (getArgs)
 
+import Link.Server
+
 main :: IO ()
 main = do
   port <- fmap (read . (!! 0)) getArgs

src/Link/Client.hs

@@ -26,11 +26,14 @@ race ioa iob = do
     bracket (forkFinally (fmap Right iob) (putMVar m)) killThread $ \_ -> do
       r <- readMVar m
       case r of
-        Left e -> throwIO e
+        Left e  -> throwIO e
         Right a -> return a
 
-sendMessage :: Message -> Client -> IO ()
+sendMessage :: Client -> Message -> IO ()
-sendMessage message Client {..} = writeChan clientChan message
+sendMessage Client {..} = writeChan clientChan
+
+sendResponse :: Client -> Message -> IO ()
+sendResponse Client {..} = printToHandle clientHandle . formatMessage
 
 runClient :: Server -> Client -> IO ()
 runClient Server {..} client@Client {..} = do
@@ -42,7 +45,7 @@ runClient Server {..} client@Client {..} = do
     pingDelayMicros = pingDelay * 1000 * 1000
 
     ping clientAlive = do
-      sendMessage Ping client
+      sendMessage client Ping
       threadDelay pingDelayMicros
       now <- getCurrentTime
       pongTime <- readMVar clientPongTime
@@ -60,12 +63,12 @@ runClient Server {..} client@Client {..} = do
             Left (e :: SomeException) -> printf "Exception: %s\n" (show e)
             Right g -> case g of
               Nothing -> run clientAlive
-              Just cm  -> do
+              Just cm -> do
                 case cm of
                   Left mcommand -> case mcommand of
                     Nothing      -> printf "Could not parse command\n"
                     Just command -> handleCommand command
-                  Right message -> sendResponse message
+                  Right message -> sendResponse client message
                 run clientAlive
 
     readCommand = do
@@ -78,10 +81,8 @@ runClient Server {..} client@Client {..} = do
     handleCommand (PrivMsg user msg) =
       withMVar serverUsers $ \clientMap ->
         case Map.lookup user clientMap of
-          Nothing      -> sendResponse $ NoSuchUser (userName user)
+          Nothing      -> sendResponse client $ NoSuchUser (userName user)
-          Just client' -> sendMessage (PrivMsg clientUser msg) client'
+          Just client' -> sendMessage client' $ PrivMsg clientUser msg
     handleCommand Pong = do
       now <- getCurrentTime
       void $ swapMVar clientPongTime now
-
-    sendResponse = printToHandle clientHandle . formatMessage

src/Link/Server.hs

@@ -1,7 +1,7 @@
 module Link.Server where
 
+import Control.Concurrent
 import Control.Exception  hiding (handle)
-import Control.Concurrent hiding (forkFinally)
 import Control.Monad      (forever)
 import Data.Time          (getCurrentTime)
 import Network            (withSocketsDo, listenOn, accept, PortID(..))
@@ -42,11 +42,11 @@ connectClient server handle = do
         let user = User name
         ok <- checkAddClient server user handle
         case ok of
-          Nothing -> do
+          Nothing     -> do
             printToHandle handle $ formatMessage (NameInUse name)
             readName
           Just client -> do
-            printToHandle handle $ formatMessage (Connected name)
+            sendResponse client $ Connected name
             runClient server client `finally` removeClient server user
 
 checkAddClient :: Server -> User -> Handle -> IO (Maybe Client)
@@ -55,13 +55,13 @@ checkAddClient Server {..} user@User {..} handle =
     if Map.member user clientMap
       then return (clientMap, Nothing)
       else do
-        clientChan <- newChan
+        clientChan     <- newChan
-        now <- newMVar =<< getCurrentTime
+        now            <- getCurrentTime
-        let client = Client user handle clientChan now
+        clientPongTime <- newMVar now
+        let client = Client user handle clientChan clientPongTime
         printf "New user connected: %s\n" userName
         return (Map.insert user client clientMap, Just client)
 
 removeClient :: Server -> User -> IO ()
 removeClient Server {..} user =
-  modifyMVar_ serverUsers $ \clientMap ->
+  modifyMVar_ serverUsers $ return . Map.delete user
-    return $ Map.delete user clientMap

src/Link/Types.hs

@@ -1,8 +1,9 @@
 module Link.Types where
 
+import Control.Concurrent (MVar, Chan)
 import Data.Time (UTCTime)
 import System.IO (Handle)
-import Control.Concurrent (MVar, Chan)
+
 import qualified Data.Map as Map
 
 type UserName = String