1
\$\begingroup\$

This is my first attempt at a chat server/client setup. It's very simple, and doesn't use any logging, excryption, or validating handshakes.

When the server is started, it displays a list of all of it's associated net addresses. This was mostly for my own purposes while testing it out, but I'm sure it might be useful for actual operation (unless you were to reserve the address on your local router).

On the client side, it only displays your received messages after you've hit enter. This was to prevent a message from being received half-way through typing a message and making a mess.

It's split into 3 modules: The client, the server, and "NetHelp", which contains several useful helpers that are used by both the client and the server.

Client:

import Control.Concurrent
import NetHelp
import Network
import System.IO

data Conn = Conn { connHand :: Handle, msgQ :: MVar [String] }

newConn :: Handle -> IO Conn
newConn h = newMVar [] >>= return . Conn h

connectToServer :: HostName -> Int -> IO Handle
connectToServer host iPort = connectTo host (toPortID iPort)

-- Add a message to a queue to be displayed later
addMsgToQ :: String -> Conn -> IO ()
addMsgToQ s (Conn _ q) = forMVar q (return . push s)

-- Waits for a message to be received
waitForMsgs :: Conn -> IO ()
waitForMsgs c@(Conn h q) = forkIO (respLoop c) >> return ()
    where respLoop c = hGetLine h >>= \resp -> 
        addMsgToQ resp c >> respLoop c

-- Clears the queue, returns the messages, and sets the queue as empty
getMsgs :: Conn -> IO [String]
getMsgs c@(Conn h q) = takeMVar q >>= \msgs -> putMVar q [] >> return msgs

-- Shows all the received messages
displayMsgs :: Conn -> IO ()
displayMsgs c = getMsgs c >>= mapM_ (\m -> putStrLn $ "\t<: " ++ m)

-- Sends out non-null messages, the flushes the handle
sendMsg :: Conn -> String -> IO ()
sendMsg (Conn h _) msg
    | not $ null msg = hPutStrLn h msg >> hFlush h
    | otherwise = return ()

startRoutine :: IO Handle
startRoutine = do
    putStr "Where do you want to connect to?\n\t"
    host <- getLine
    putStr "What port do you want to connect to?\n\t"
    iPort <- getInt notAValidPortFn
    connectToServer host iPort

main = withSocketsDo $ do
    conn <- newConn =<< startRoutine
    waitForMsgs conn
    msgLoop conn
    where msgLoop c = displayMsgs c >>
        putStr ">: " >> getLine >>= sendMsg c >> msgLoop c

Server:

import Control.Concurrent
import Control.Exception
import Control.Monad
import Data.List
import NetHelp
import Network
import System.IO

data RThread    = NoThread | RThread ThreadId
                    deriving (Eq, Show)
data Conn       = Conn { connName :: String, connHand :: Handle, connRespId :: RThread }
                    --deriving (Show)
data ConnChan   = ConnChan { conns :: MVar [Conn], servePort :: PortID }

-- Ignores the ThreadID
instance Eq Conn where
    (Conn cN cH _) == (Conn cN' cH' _) = cN == cN' && cH == cH'

instance Show Conn where
    show (Conn n h t) = "(" ++ show n ++ " - " ++ show h ++ " - " ++ show t ++ ")"

newConnChan :: Int -> IO ConnChan
newConnChan iP = newMVar [] >>= \mV -> return $ ConnChan mV (toPortID iP)

newConn :: String -> Handle -> Conn
newConn n h = Conn n h NoThread

setRThread :: Conn -> ThreadId -> Conn
setRThread c t = c { connRespId = RThread t }

applyToConns :: ([Conn] -> IO [Conn]) -> ConnChan -> IO ()
applyToConns f (ConnChan { conns = cs }) = mapMVar f cs

-- Spawns a listening thread, "attaches" it to Conn, and add it to the list of connections
addConn :: String -> Handle -> ConnChan -> IO ()
addConn n h cc = let conn = newConn n h in spawnListener conn cc >>= \lT ->
    applyToConns (\cs -> return $ (setRThread conn lT) : cs) cc

safeChanMap :: (Conn -> IO Conn) -> ConnChan -> IO ()
safeChanMap f (ConnChan cs _) = mapMVar (safeConnMap f) cs

--Written by a SO user to re-wrap a value after evaluation.
returnEval :: Monad m => a -> IO (m a)
returnEval x = evaluate x >>= return . return

-- Maps over a list of connections, killing and removing any connections that throw an exception
safeConnMap :: (Conn -> IO Conn) -> [Conn] -> IO [Conn]
safeConnMap f []       = return []
safeConnMap f (x : xs) = do
    restResult <- safeConnMap f xs
    appliedResult <- catch (f x >>= returnEval)
        (\e -> (e :: SomeException) `seq` return Nothing)
    case appliedResult of
        Just x' -> return $ x' : restResult
        Nothing -> killConn x >> return restResult

-- Kills a connection
killConn :: Conn -> IO ()
killConn c@(Conn n h (RThread t)) = hClose h >> killThread t >> (putStrLn $ n ++ " was disconnected")

-- Prints a list of the currently connected users
printConnected :: ConnChan -> IO ()
printConnected (ConnChan mcs _) = forMVar_ mcs $ \cs -> case cs of
    []  -> return ()
    _   -> putStrLn (concatMap (\c@(Conn n _ _) -> n ++ " | ") cs) >> putStrLn ""

-- Helper that attaches a sender's name to the message,
--    and flushes a handle after sending a message
sendMsg :: Conn -> String -> IO ()
sendMsg (Conn n h _) s = let msg = n ++  ": " ++ s in
    hPutStrLn h msg >> hFlush h

-- Send a message to all the currently connected users, except for the sending user
broadcast :: String -> Conn -> ConnChan -> IO ()
broadcast s sendC = safeChanMap $ \c ->
    (if c /= sendC then sendMsg c s else return ()) >> return c

-- Creates a thread that waits for a client to send a message,
--    then returns to ID so it can be killed later
spawnListener :: Conn -> ConnChan -> IO ThreadId
spawnListener c cc = forkIO $ broadcastResp c cc

-- Waits for a message, then broadcasts it out
broadcastResp :: Conn -> ConnChan -> IO ()
broadcastResp c@(Conn n h _) cc = hGetLine h >>= \resp ->
    broadcast resp c cc >> broadcastResp c cc

-- Periodically displays the connected users
--    Involves printing on a seperate thread, so it can create garbled text
periodConnDisplay :: Int -> ConnChan -> IO ()
periodConnDisplay s cc = (forkIO loop) >> return ()
        where loop = threadDelay (s * 1000000) >> printConnected cc >> loop

main = withSocketsDo $ do
    putStr "What port do you want to listen on?\n\t"
    iPort <- getInt notAValidPortFn
    chan <- newConnChan iPort
    periodConnDisplay 30 chan
    showPossAdd >>= putStrLn
    putStrLn $ "Listening on " ++ show (servePort chan)
    s <- listenOn (servePort chan)
    forever $ do
        (h, ho, _) <- accept s
        let name = (cutName ho)
        addConn name h chan
        printConnected chan
        broadcast (show name ++ " connected") (newConn name h) chan

NetHelp:

import Control.Concurrent
import Control.Exception
import Data.Char
import Network
import Network.Info

notAValidPortFn = (++ " is not a valid port")

getInt :: (String -> String) -> IO Int
getInt errFn = getLine >>= \s ->
    if all isDigit s then return $ read s else putStrLn (errFn s) >> getInt errFn

toPortID :: Integral i => i -> PortID
toPortID = PortNumber . fromIntegral

debug :: String -> IO ()
debug = putStrLn

cutName :: String -> String
cutName = takeWhile (/= '.')

possAdd s = not $ elem s ["0.0.0.0", "127.0.0.1"]

-- Adds a message to the end of a list (FIFO-style queue)
push :: a -> [a] -> [a]
push x [] = x : []
push x (y : ys) = y : push x ys

-- Returns a list of network interface names and addresses
getPossibleAddresses :: IO [String]
getPossibleAddresses = getNetworkInterfaces >>=
    return . foldl (\acc n -> let strAdd = show $ ipv4 n in
        if possAdd strAdd then (name n ++ ": " ++ strAdd) : acc else acc) []

showPossAdd :: IO String
showPossAdd = getPossibleAddresses >>= return . concatMap (++ "\n")

-- Helper functions that unwrap/rewrap MVars, applying a result in between.
--    The _ versions are for purely side effect functions.
mapMVar :: (a -> IO a) -> MVar a -> IO ()
mapMVar f mv = takeMVar mv >>= f >>= putMVar mv

mapMVar_ :: (a -> IO ()) -> MVar a -> IO ()
mapMVar_ f mv = takeMVar mv >>= \x -> f x >> putMVar mv x

forMVar = flip mapMVar

forMVar_ = flip mapMVar_

Any critique would be appreciated. This is the most complex net program I've ever written, so I'd like to know if anything I've done is exceptionally good/bad practice, or just generally anything that warrants a comment.

I'd also like ideas on where I can take it from here. Any ideas for future extentions would be nice.

To use the client/server, just run main and follow the prompts.

\$\endgroup\$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Browse other questions tagged or ask your own question.