Spilts server into more modules.

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

src/Link/Server.hs

@@ -1,18 +1,19 @@
 module Link.Server where
 
-import Control.Exception  (finally, bracket, throwIO, try, SomeException,
+import Control.Exception  hiding (handle)
-                           AsyncException(ThreadKilled))
+import Control.Concurrent hiding (forkFinally)
-import Control.Concurrent
 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)
+     forkIO (connectClient server handle) `finally` (hClose handle)
-
-printToHandle :: Handle -> String -> IO ()
-printToHandle handle str = hPrintf handle "%s\n" str
 
 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 ->

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