Adds partial implementation of channel join/leave using MVars.

src/Link/Client.hs

@@ -10,6 +10,7 @@ import System.Timeout         (timeout)
 import Text.Printf            (printf)
 
 import qualified Data.Map.Strict as Map
+import qualified Data.Set as Set
 
 import Link.Protocol
 import Link.Types
@@ -71,13 +72,32 @@ runClient Server {..} client@Client {..} = do
         Nothing -> printf "Could not parse command: %s\n" command
         Just c  -> sendMessageIO client c
 
-    handleMessage (Msg user msg) _ =
+    handleMessage (Msg user msg) _     =
       withMVar serverUsers $ \clientMap ->
         case Map.lookup user clientMap of
           Nothing      -> sendResponse client $ NoSuchUser (userName user)
           Just client' -> sendMessageIO client' $ MsgReply clientUser msg
-    handleMessage Pong _           = do
+    handleMessage Pong _               = do
       now <- getCurrentTime
       void $ swapMVar clientPongTime now
-    handleMessage Quit clientAlive = killClient clientAlive
+    handleMessage Quit clientAlive     = killClient clientAlive
-    handleMessage message _        = sendResponse client message
+    handleMessage (Join channelName) _ = do
+      modifyMVar_ serverChannels $ \channelMap -> do
+        case Map.lookup channelName channelMap of
+          Just (Channel {channelUsers}) -> do
+            modifyMVar_ channelUsers $ return . Set.insert clientUser
+            return channelMap
+          Nothing             -> do
+            channel <- newChannel channelName $ Set.singleton clientUser
+            return $ Map.insert channelName channel channelMap
+    handleMessage (Leave channelName) _ = do
+      modifyMVar_ serverChannels $ \channelMap -> do
+        case Map.lookup channelName channelMap of
+          Just (Channel {channelUsers}) -> do
+            modifyMVar_ channelUsers $ return . Set.delete clientUser
+            users <- readMVar channelUsers
+            return $ if Set.null users
+              then Map.delete channelName channelMap
+              else channelMap
+          Nothing             -> return channelMap
+    handleMessage message _            = sendResponse client message

src/Link/Protocol.hs

@@ -9,11 +9,15 @@ parseCommand command = case words command of
   ["PONG"]               -> Just Pong
   "MSG" : userName : msg -> Just $ Msg (User userName) (unwords msg)
   ["QUIT"]               -> Just $ Quit
+  "JOIN" : channelName   -> Just $ Join (unwords channelName)
+  "LEAVE" : channelName  -> Just $ Leave (unwords channelName)
   _                      -> Nothing
 
 formatMessage :: Message -> String
-formatMessage (MsgReply user msg) = printf "MSG %s %s" (userName user) msg
+formatMessage (MsgReply user msg)       = printf "MSG %s %s" (userName user) msg
-formatMessage (NameInUse name)    = printf "NAMEINUSE %s" name
+formatMessage (NameInUse name)          = printf "NAMEINUSE %s" name
-formatMessage (Connected name)    = printf "CONNECTED %s" name
+formatMessage (Connected name)          = printf "CONNECTED %s" name
-formatMessage Ping                = "PING"
+formatMessage Ping                      = "PING"
-formatMessage (NoSuchUser name)   = printf "NOSUCHUSER %s" name
+formatMessage (NoSuchUser name)         = printf "NOSUCHUSER %s" name
+formatMessage (Joined channelName user) = printf "JOINED %s %s" channelName (userName user)
+formatMessage (Leaved channelName user) = printf "LEFT %s %s" channelName (userName user)

src/Link/Server.hs

@@ -1,10 +1,8 @@
 module Link.Server where
 
 import Control.Concurrent
-import Control.Concurrent.STM (newTChanIO)
 import Control.Exception      hiding (handle)
 import Control.Monad          (forever)
-import Data.Time              (getCurrentTime)
 import Network                (withSocketsDo, listenOn, accept, PortID(..))
 import System.IO              (hClose, hSetNewlineMode, hSetBuffering, BufferMode(..),
                                universalNewlineMode, hGetLine, Handle, stdout)
@@ -20,10 +18,7 @@ import Link.Util
 runServer :: Int -> IO ()
 runServer port = withSocketsDo $ do
   hSetBuffering stdout LineBuffering
-
+  server <- newServer
-  serverUsers <- newMVar Map.empty
-  let server = Server serverUsers
-
   sock <- listenOn . PortNumber . fromIntegral $ port
   printf "Listening on port %d\n" port
   forever $ do
@@ -58,10 +53,7 @@ checkAddClient Server {..} user@User {..} handle =
     if Map.member user clientMap
       then return (clientMap, Nothing)
       else do
-        clientChan     <- newTChanIO
+        client <- newClient user handle
-        now            <- getCurrentTime
-        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)
 

src/Link/Types.hs

@@ -1,15 +1,15 @@
 module Link.Types where
 
-import Control.Concurrent     (MVar)
+import Control.Concurrent
-import Control.Concurrent.STM (TVar, TChan)
+import Control.Concurrent.STM (TVar, TChan, newTVarIO, newTChanIO, newBroadcastTChanIO)
-import Data.Time              (UTCTime)
+import Data.Time              (UTCTime, getCurrentTime)
 import System.IO              (Handle)
 
 import qualified Data.Map as Map
 import qualified Data.Set as Set
 
 type UserName = String
-type RoomName = String
+type ChannelName = String
 
 data User = User { userName :: !UserName }
             deriving (Show, Eq, Ord)
@@ -17,20 +17,50 @@ data User = User { userName :: !UserName }
 data Client = Client {
                 clientUser     :: !User
               , clientHandle   :: !Handle
-              , clientChan     :: !(TChan Message)
+              , clientChan     :: TChan Message
               , clientPongTime :: MVar UTCTime
               }
 
+newClient :: User -> Handle -> IO Client
+newClient user handle = do
+  clientChan     <- newTChanIO
+  now            <- getCurrentTime
+  clientPongTime <- newMVar now
+  return $ Client user handle clientChan clientPongTime
+
+data Channel = Channel {
+              channelName  :: !ChannelName
+            , channelUsers :: MVar (Set.Set User)
+            , channelChan  :: TChan Message
+            }
+
+newChannel :: ChannelName -> Set.Set User -> IO Channel
+newChannel channelName users = do
+  channelUsers <- newMVar users
+  channelChan  <- newBroadcastTChanIO
+  return $ Channel channelName channelUsers channelChan
+
 data Server = Server {
-                serverUsers :: MVar (Map.Map User Client)
+                serverUsers    :: MVar (Map.Map User Client)
+              , serverChannels :: MVar (Map.Map ChannelName Channel)
               }
 
+newServer :: IO Server
+newServer = do
+  serverUsers    <- newMVar Map.empty
+  serverChannels <- newMVar Map.empty
+  return $ Server serverUsers serverChannels
+
 data Message = NameInUse UserName
              | Connected UserName
              | Ping
              | MsgReply User String
              | NoSuchUser UserName
+             | Joined ChannelName User
+             | Leaved ChannelName User
              | Pong
              | Msg User String
+             | Join ChannelName
+             | Leave ChannelName
              | Quit
                deriving (Show, Eq)