Adds a login command.

src/Link/Protocol.hs

@@ -9,6 +9,7 @@ import Link.Types
 parseCommand :: String -> Maybe Message
 parseCommand command = case words command of
   ["PONG"]                   -> Just Pong
+  "LOGIN" : userName         -> Just $ Login (unwords userName)
   "MSG" : userName : msg     -> Just $ Msg (User userName) (unwords msg)
   "TELL" : channelName : msg -> Just $ Tell channelName (unwords msg)
   ["QUIT"]                   -> Just Quit
@@ -20,7 +21,7 @@ parseCommand command = case words command of
 formatMessage :: Message -> String
 formatMessage (MsgReply user msg)       = printf "MSG %s %s" (userName user) msg
 formatMessage (NameInUse name)          = printf "NAMEINUSE %s" name
-formatMessage (Connected name)          = printf "CONNECTED %s" name
+formatMessage (LoggedIn name)           = printf "LOGGEDIN %s" name
 formatMessage Ping                      = "PING"
 formatMessage (NoSuchUser name)         = printf "NOSUCHUSER %s" name
 formatMessage (Joined channelName user) = printf "JOINED %s %s" channelName (userName user)

src/Link/Server.hs

@@ -1,12 +1,12 @@
 module Link.Server where
 
 import Control.Concurrent
-import Control.Exception      hiding (handle)
+import Control.Exception  hiding (handle)
-import Control.Monad          (forever)
+import Control.Monad      (forever)
-import Network                (withSocketsDo, listenOn, accept, PortID(..))
+import Network            (withSocketsDo, listenOn, accept, PortID(..))
-import System.IO              (hClose, hSetNewlineMode, hSetBuffering, BufferMode(..),
+import System.IO          (hClose, hSetNewlineMode, hSetBuffering, BufferMode(..),
-                               universalNewlineMode, hGetLine, Handle, stdout)
+                           universalNewlineMode, hGetLine, Handle, stdout)
-import Text.Printf            (printf)
+import Text.Printf        (printf)
 
 import qualified Data.Map.Strict as Map
 
@@ -32,19 +32,19 @@ connectClient server handle = do
   readName
   where
     readName = do
-      name <- hGetLine handle
+      command <- fmap parseCommand $ hGetLine handle
-      if null name
+      case command of
-      then readName
+        Just (Login name) -> do
-      else do
+          let user = User name
-        let user = User name
+          ok <- checkAddClient server user handle
-        ok <- checkAddClient server user handle
+          case ok of
-        case ok of
+            Nothing     -> do
-          Nothing     -> do
+              printToHandle handle . formatMessage $ NameInUse name
-            printToHandle handle . formatMessage $ NameInUse name
+              readName
-            readName
+            Just client -> do
-          Just client -> do
+              printToHandle handle . formatMessage $ LoggedIn name
-            printToHandle handle . formatMessage $ Connected name
+              runClient server client `finally` removeClient server user
-            runClient server client `finally` removeClient server user
+        _ -> readName
 
 checkAddClient :: Server -> User -> Handle -> IO (Maybe Client)
 checkAddClient Server {..} user@User {..} handle =

src/Link/Types.hs

@@ -54,7 +54,7 @@ newServer = do
   return $ Server serverUsers serverChannels
 
 data Message = NameInUse UserName
-             | Connected UserName
+             | LoggedIn UserName
              | Ping
              | MsgReply User String
              | TellReply ChannelName User String
@@ -63,6 +63,7 @@ data Message = NameInUse UserName
              | Leaved ChannelName User
              | NamesReply ChannelName (Set.Set User)
              | Pong
+             | Login UserName
              | Msg User String
              | Tell ChannelName String
              | Join ChannelName