How to resolve the algorithm Chat server step by step in the Haskell programming language
How to resolve the algorithm Chat server step by step in the Haskell programming language
Table of Contents
Problem Statement
Write a server for a minimal text based chat. People should be able to connect via ‘telnet’, sign on with a nickname, and type messages which will then be seen by all other connected users. Arrivals and departures of chat members should generate appropriate notification messages.
Let's start with the solution:
Step by Step solution about How to resolve the algorithm Chat server step by step in the Haskell programming language
The code you provided is a server application written in Haskell using the Network library. It allows multiple clients to connect to the server and chat with each other.
The main function sets up a server on port 5002 and starts a loop that waits for clients to connect. When a client connects, the server creates a new thread to handle the client's connection. The thread runs the userChat function, which prompts the client for a username and then allows them to chat with other clients.
The userChat function uses the ReaderT monad transformer to pass the current thread data (the handle to the client's socket and the map of usernames to handles) to each step of the computation. It also uses the Error monad transformer to handle errors that may occur during the computation.
The userChat function first prompts the client for a username and then checks if the username is already in use. If the username is already in use, the server sends an error message to the client and prompts them to enter a new username. If the username is not in use, the server adds the client's handle to the map of usernames to handles and sends a welcome message to the client.
The userChat function then enters a loop that waits for the client to send a message. When the client sends a message, the server broadcasts the message to all other clients. The broadcast function uses the Map library to iterate over the map of usernames to handles and send the message to each client.
The clientLoop function is responsible for handling the client's connection. It accepts a socket and a map of usernames to handles as arguments and then creates a new thread to handle the client's connection. The thread runs the userChat function, which prompts the client for a username and then allows them to chat with other clients.
The main function starts the server and then enters a loop that waits for clients to connect. When a client connects, the server creates a new thread to handle the client's connection. The thread runs the userChat function, which prompts the client for a username and then allows them to chat with other clients.
Source code in the haskell programming language
{-# LANGUAGE OverloadedStrings #-}
import Network
import System.IO
import Control.Concurrent
import qualified Data.Text as T
import Data.Text (Text)
import qualified Data.Text.IO as T
import qualified Data.Map as M
import Data.Map (Map)
import Control.Monad.Reader
import Control.Monad.Error
import Control.Exception
import Data.Monoid
import Control.Applicative
type ServerApp = ReaderT ThreadData IO
data Speaker = Server | Client Text
data ThreadData = ThreadData { threadHandle :: Handle
, userTableMV :: MVar (Map Text Handle)}
echoLocal = liftIO . T.putStrLn
echoRemote = echoMessage . (">> "<>)
echoMessage msg = viewHandle >>= \h -> liftIO $ T.hPutStrLn h msg
getRemoteLine = viewHandle >>= liftIO . T.hGetLine
putMVarT = (liftIO.) . putMVar
takeMVarT = liftIO . takeMVar
readMVarT = liftIO . readMVar
modifyUserTable fn = viewUsers >>= \mv ->
liftIO $ modifyMVar_ mv (return . fn)
viewHandle = threadHandle <$> ask
viewUsers = userTableMV <$> ask
userChat :: ServerApp ()
userChat = do
name <- addUser
echoLocal name
h <- viewHandle
(flip catchError) (\_ -> removeUser name) $
do echoLocal $ "Accepted " <> name
forever $ getRemoteLine >>= broadcast (Client name)
removeUser :: Text -> ServerApp ()
removeUser name = do
echoLocal $ "Exception with " <> name <> ", removing from userTable"
broadcast Server $ name <> " has left the server"
modifyUserTable (M.delete name)
addUser :: ServerApp Text
addUser = do
h <- viewHandle
usersMV <- viewUsers
echoRemote "Enter username"
name <- T.filter (/='\r') <$> getRemoteLine
userTable <- takeMVarT usersMV
if name `M.member` userTable
then do echoRemote "Username already exists!"
putMVarT usersMV userTable
addUser
else do putMVarT usersMV (M.insert name h userTable)
broadcast Server $ name <> " has joined the server"
echoRemote "Welcome to the server!\n>> Other users:"
readMVarT usersMV >>=
mapM_ (echoRemote . ("*" <>) . fst)
. filter ((/=name). fst) . M.toList
return name
broadcast :: Speaker -> Text -> ServerApp ()
broadcast user msg =
viewUsers >>= readMVarT >>= mapM_ (f . snd) . fn . M.toList
where f h = liftIO $ T.hPutStrLn h $ nm <> msg
(fn, nm) = case user of
Server -> (id, ">> ")
Client t -> (filter ((/=t) . fst), t <> "> ")
clientLoop socket users = do
(h, _, _) <- accept socket
hSetBuffering h LineBuffering
forkIO $ runReaderT userChat (ThreadData h users)
clientLoop socket users
main = do
server <- listenOn $ PortNumber 5002
T.putStrLn "Server started"
newMVar (M.empty) >>= clientLoop server
You may also check:How to resolve the algorithm Mutual recursion step by step in the 8080 Assembly programming language
You may also check:How to resolve the algorithm Identity matrix step by step in the Mathematica / Wolfram Language programming language
You may also check:How to resolve the algorithm Temperature conversion step by step in the PHP programming language
You may also check:How to resolve the algorithm CRC-32 step by step in the J programming language
You may also check:How to resolve the algorithm Proper divisors step by step in the Modula-2 programming language