module Network.SimpleServer.Examples.ChatServer(main, run) where
import Data.Char
import Data.List
import System.Environment
import qualified Network.SimpleServer as S
welcomeMessage = "Welcome to the Simple Chat Server.\n" ++
"Commands:\n" ++
"/message [message] - Broadcast a message to all users.\n" ++
"/name [newname] - Change your name to newname.\n" ++
"/ping - Let's the server know you're still there.\n" ++
"/who - Displays a list of users connected to the server.\n" ++
"/disconnect - Disconnect from Simple Chat Server.\n"
username = "username"
connHandler :: S.ConnectionHandler
connHandler server client = do
let name = "user #" ++ (show (S.cid client))
msg = name ++ " connected."
S.modify client username name
S.broadcast server msg
S.respond client welcomeMessage
dissHandler :: S.DisconnectHandler
dissHandler server client = do
name <- S.lookup client username
let msg = name ++ " disconnected."
S.respond client "disconnected"
S.broadcast server msg
nameCmd = "/name"
nameHandler :: S.CmdHandler
nameHandler (_:msg) server client = do
case msg of
[] -> S.respond client "You did not provide a name to change to."
msg -> do
before <- S.lookup client username
let name = intercalate " " msg
message = before ++ " is now known as " ++ name
S.modify client username (intercalate " " msg)
S.broadcast server message
pingCmd = "/ping"
pingHandler :: S.CmdHandler
pingHandler (_:flag) _ client = do
case flag of
("silent":_) -> return ()
_ -> S.respond client "Ping received."
msgCmd = "/message"
msgHandler :: S.CmdHandler
msgHandler (cmd:msg) server client = do
name <- S.lookup client username
S.broadcast server $ name ++ "> " ++ (unwords msg)
disCmd = "/disconnect"
disHandler :: S.CmdHandler
disHandler _ server client = do
S.respond client "Goodbye!"
S.disconnect client
whoCmd = "/who"
whoHandler :: S.CmdHandler
whoHandler _ server client = do
clients <- S.clientList server
usernames <- mapM (flip S.lookup username) clients
let message = "Users:\n" ++ (intercalate "\n" usernames)
S.respond client message
run :: Int -> IO ()
run port = do
server <- S.new connHandler dissHandler port
S.addCommand server whoCmd whoHandler
S.addCommand server nameCmd nameHandler
S.addCommand server disCmd disHandler
S.addCommand server msgCmd msgHandler
S.addCommand server pingCmd pingHandler
S.start server
putStrLn $ "Chat Server Started on Port: " ++ (show port)
putStrLn $ "Type 'stop' to stop the server."
waitStop server
S.stop server
putStrLn "Server Stopped"
waitStop :: S.Server -> IO ()
waitStop server = do
string <- getLine
case string of
"stop" -> return ()
_ -> waitStop server
main = do
args <- getArgs
case args of
[] -> printUsage
(x:_) -> if isInt x then (return (read x)) >>= run else printUsage
printUsage :: IO ()
printUsage = putStrLn "Usage ./ChatServer [port]"
isInt :: [Char] -> Bool
isInt = (== []) . (filter (not . isDigit))