Adds partial implementation of channel join/leave using MVars.
parent
130b556c56
commit
478a91d93f
|
|
@ -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 message _ = sendResponse client message
|
||||
handleMessage Quit clientAlive = killClient clientAlive
|
||||
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
|
||||
|
|
|
|||
|
|
@ -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 (NameInUse name) = printf "NAMEINUSE %s" name
|
||||
formatMessage (Connected name) = printf "CONNECTED %s" name
|
||||
formatMessage Ping = "PING"
|
||||
formatMessage (NoSuchUser name) = printf "NOSUCHUSER %s" name
|
||||
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 Ping = "PING"
|
||||
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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
serverUsers <- newMVar Map.empty
|
||||
let server = Server serverUsers
|
||||
|
||||
server <- newServer
|
||||
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
|
||||
now <- getCurrentTime
|
||||
clientPongTime <- newMVar now
|
||||
let client = Client user handle clientChan clientPongTime
|
||||
client <- newClient user handle
|
||||
printf "New user connected: %s\n" userName
|
||||
return (Map.insert user client clientMap, Just client)
|
||||
|
||||
|
|
|
|||
|
|
@ -1,15 +1,15 @@
|
|||
module Link.Types where
|
||||
|
||||
import Control.Concurrent (MVar)
|
||||
import Control.Concurrent.STM (TVar, TChan)
|
||||
import Data.Time (UTCTime)
|
||||
import Control.Concurrent
|
||||
import Control.Concurrent.STM (TVar, TChan, newTVarIO, newTChanIO, newBroadcastTChanIO)
|
||||
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)
|
||||
|
|
|
|||
Loading…
Reference in New Issue