Server: separate into couple of modules

Hach.cabal

@@ -50,7 +50,9 @@ Executable hach-nclient
 Executable hach-server
   Main-is:              Server.hs
   HS-Source-Dirs:       server, libhach
-  Other-modules:        Storage
+  Other-modules:        Server.Client
+                        Server.Message
+                        Server.Storage
 
 Source-repository head
   type: git

server/Server.hs

@@ -9,65 +9,28 @@ import Control.Concurrent
 import Network.Socket
 import System.IO
 
-import Storage
+import Server.Client
+import Server.Message
+import Server.Storage
 import Hach.Types
 
-readC ∷ Chan (Int, S2C) → Handle → IO ()
-readC ch h = do
-  (_, message) ← readChan ch
-  hPrint h message
-
-client ∷ Storage → Chan (Int, S2C) → Handle → Int → IO ()
-client storage ch h cId = do
-  ch' ← dupChan ch
-  forkIO $ handle_ $ forever $ readC ch' h
-  forever $ do
-    m ← hGetLine h
-    maybeNick ← getNick storage cId
-    case maybeNick of
-      Just nick → do
-        go nick $ read m
-        putStrLn m
-        where go ∷ Nick → C2S → IO ()
-              go n (CMessage t) = writeChan ch' (cId, SMessage n t)
-              go n (CAction t) = writeChan ch' (cId, SAction n t)
-              go _ (CSetNick t) = do
-                nickExists ← doesNickExist storage t
-                if nickExists
-                  then hPrint h $ SSystem $ "nick " ++ t ++ " is already in use"
-                  else do writeChan ch' (cId, SSetNick nick ("is known as " ++ t))
-                          putNick storage cId t
-      Nothing → do
-        go $ read m
-        putStrLn m
-        where go ∷ C2S → IO ()
-              go (CMessage _) = hPrint h $ SSystem "Undefined client nick"
-              go (CAction  _) = hPrint h $ SSystem "Undefined client nick"
-              go (CSetNick t) = do
-                nickExists ← doesNickExist storage t
-                if nickExists
-                  then do hPrint h $ SSystem $  "nick " ++ t ++ " is already in use"
-                  else do writeChan ch' (cId, SSystem $ t ++ " is connected")
-                          putNick storage cId t
-  where handle_ = handle $ \(SomeException e) → print e
-
 serve ∷ Socket → Storage → Chan (Int, S2C) → Int → IO ()
 serve sock storage ch !cId = do
   (s, _) ← accept sock
   h ← socketToHandle s ReadWriteMode
   hSetBuffering h LineBuffering
-  forkIO $ handle (onDisconnect ch) $ client storage ch h cId
+  forkIO $ handle (onDisconnect ch) $ clientProcessing storage ch h cId
   serve sock storage ch $ cId + 1
   where 
     onDisconnect ∷ Chan (Int, S2C) → SomeException → IO ()
     onDisconnect ch' _ = do
       maybeNick ← getNick storage cId
       case maybeNick of
         Just nick → do
-          writeChan ch' (cId, SSystem $ nick ++ " has quit conversation")
+          writeChan ch' (cId, leftClientM nick)
           delId storage cId
           showStorage storage
-        Nothing → putStrLn "Error: undefined user has quit conversation"
+        Nothing → putStrLn "Error: undefined user has left conversation"
 
 main ∷ IO ()
 main = withSocketsDo $ do
@@ -79,4 +42,3 @@ main = withSocketsDo $ do
   ch ← newChan
   forkIO $ forever $ readChan ch >>= const (return ())
   serve sock storage ch 0
-

server/Server/Client.hs

@@ -0,0 +1,49 @@
+{-# LANGUAGE UnicodeSyntax #-}
+module Server.Client (clientProcessing) where
+
+import Control.Applicative ((<$>))
+import Control.Concurrent
+import Control.Exception
+import Control.Monad (forever)
+import System.IO
+
+import Hach.Types
+import Server.Message
+import Server.Storage
+
+readC ∷ Chan (Int, S2C) → Handle → IO ()
+readC ch h = hPrint h =<< snd <$> readChan ch
+
+clientProcessing ∷ Storage → Chan (Int, S2C) → Handle → Int → IO ()
+clientProcessing storage ch h cId = do
+  ch' ← dupChan ch
+  forkIO $ handle_ $ forever $ readC ch' h
+  forever $ do
+    m ← hGetLine h
+    maybeNick ← getNick storage cId
+    case maybeNick of
+      Just nick → do
+        go nick $ read m
+        putStrLn m
+        where go ∷ Nick → C2S → IO ()
+              go n (CMessage t) = writeChan ch' (cId, SMessage n t)
+              go n (CAction t) = writeChan ch' (cId, SAction n t)
+              go _ (CSetNick t) = do
+                nickExists ← doesNickExist storage t
+                if nickExists
+                  then hPrint h $ existedNickM t
+                  else do writeChan ch' (cId, settedNickM nick t)
+                          putNick storage cId t
+      Nothing → do
+        go $ read m
+        putStrLn m
+        where go ∷ C2S → IO ()
+              go (CMessage _) = hPrint h undefinedNickM
+              go (CAction  _) = hPrint h undefinedNickM
+              go (CSetNick t) = do
+                nickExists ← doesNickExist storage t
+                if nickExists
+                  then do hPrint h $ existedNickM t
+                  else do writeChan ch' (cId, connectedClientM t)
+                          putNick storage cId t
+  where handle_ = handle $ \(SomeException e) → print e

server/Server/Message.hs

@@ -0,0 +1,19 @@
+{-# LANGUAGE UnicodeSyntax #-}
+module Server.Message where
+
+import Hach.Types
+
+connectedClientM ∷ Nick → S2C
+connectedClientM nick = SSystem $ nick ++ " is connected."
+
+existedNickM ∷ Nick → S2C
+existedNickM nick = SSystem $ "Nickname " ++ nick ++ " is already in use."
+
+leftClientM ∷ Nick → S2C
+leftClientM nick = SSystem $ nick ++ " has left conversation."
+
+settedNickM ∷ Nick → Nick → S2C
+settedNickM nickFrom nickTo = SSetNick nickFrom $ "is know as " ++ nickTo ++ "."
+
+undefinedNickM ∷ S2C
+undefinedNickM = SSystem "To join a chat please set another nick with /nick command."

server/Storage.hs → server/Server/Storage.hs

@@ -1,6 +1,6 @@
 {-# LANGUAGE UnicodeSyntax #-}
 
-module Storage
+module Server.Storage
   ( Storage(..)
   , newStorage, getNick, putNick, delId
   , doesNickExist