Instantly share code, notes, and snippets.

Embed
What would you like to do?
A re-implementation of Simon Marlow's Async Haskell Chat Server using Conduits
{-# LANGUAGE OverloadedStrings, RecordWildCards, LambdaCase #-}
import Conduit
import Data.Conduit
import Data.Conduit.Network
import qualified Data.ByteString.Char8 as BS
import Data.Conduit.TMChan
import Text.Printf (printf)
import Control.Concurrent.STM
import qualified Data.Map as Map
import Data.Word8 (_cr)
import Control.Monad
import Control.Concurrent.Async (concurrently)
import Control.Exception (finally)
type ClientName = BS.ByteString
data Client = Client
{ clientName :: ClientName
, clientChan :: TMChan Message
, clientApp :: AppData
}
instance Show Client where
show client =
BS.unpack (clientName client) ++ "@"
++ show (appSockAddr $ clientApp client)
data Server = Server {
clients :: TVar (Map.Map ClientName Client)
}
data Message = Notice BS.ByteString
| Tell ClientName BS.ByteString
| Broadcast ClientName BS.ByteString
| Command BS.ByteString
deriving Show
newServer :: IO Server
newServer = do
c <- newTVarIO Map.empty
return Server { clients = c }
newClient :: ClientName -> AppData -> STM Client
newClient name app = do
chan <- newTMChan
return Client { clientName = name
, clientApp = app
, clientChan = chan
}
broadcast :: Server -> Message -> STM ()
broadcast Server{..} msg = do
clientmap <- readTVar clients
mapM_ (\client -> sendMessage client msg) (Map.elems clientmap)
sendMessage :: Client -> Message -> STM ()
sendMessage Client{..} msg = writeTMChan clientChan msg
(<++>) = BS.append
handleMessage :: Server -> Client -> Conduit Message IO BS.ByteString
handleMessage server client@Client{..} = awaitForever $ \case
Notice msg -> output $ "*** " <++> msg
Tell name msg -> output $ "*" <++> name <++> "*: " <++> msg
Broadcast name msg -> output $ "<" <++> name <++> ">: " <++> msg
Command msg -> case BS.words msg of
["/tell", who, what] -> do
ok <- liftIO $ atomically $
sendToName server who $ Tell clientName what
unless ok $ output $ who <++> " is not connected."
["/help"] ->
mapM_ output [ "------ help -----"
, "/tell <who> <what> - send a private message"
, "/list - list users online"
, "/help - show this message"
, "/quit - leave"
]
["/list"] -> do
cl <- liftIO $ atomically $ listClients server
output $ BS.concat $
"----- online -----\n" : map ((flip BS.snoc) '\n') cl
["/quit"] -> do
error . BS.unpack $ clientName <++> " has quit"
-- ignore empty strings
[""] -> return ()
[] -> return ()
-- broadcasts
ws ->
if BS.head (head ws) == '/' then
output $ "Unrecognized command: " <++> msg
else
liftIO $ atomically $
broadcast server $ Broadcast clientName msg
where
output s = yield (s <++> "\n")
listClients :: Server -> STM [ClientName]
listClients Server{..} = do
c <- readTVar clients
return $ Map.keys c
sendToName :: Server -> ClientName -> Message -> STM Bool
sendToName server@Server{..} name msg = do
clientmap <- readTVar clients
case Map.lookup name clientmap of
Nothing -> return False
Just client -> sendMessage client msg >> return True
checkAddClient :: Server -> ClientName -> AppData -> IO (Maybe Client)
checkAddClient server@Server{..} name app = atomically $ do
clientmap <- readTVar clients
if Map.member name clientmap then
return Nothing
else do
client <- newClient name app
writeTVar clients $ Map.insert name client clientmap
broadcast server $ Notice (name <++> " has connected")
return (Just client)
readName :: Server -> AppData -> ConduitM BS.ByteString BS.ByteString IO Client
readName server app = go
where
go = do
yield "What is your name? "
name <- lineAsciiC $ takeCE 80 =$= filterCE (/= _cr) =$= foldC
if BS.null name then
go
else do
ok <- liftIO $ checkAddClient server name app
case ok of
Nothing -> do
respond "The name '%s' is in use, please choose another\n" name
go
Just client -> do
respond "Welcome, %s!\nType /help to list commands.\n" name
return client
respond msg name = yield $ BS.pack $ printf msg $ BS.unpack name
clientSink :: Client -> Sink BS.ByteString IO ()
clientSink Client{..} = mapC Command =$ sinkTMChan clientChan True
runClient :: ResumableSource IO BS.ByteString -> Server -> Client -> IO ()
runClient clientSource server client@Client{..} =
void $ concurrently
(clientSource $$+- linesUnboundedAsciiC =$ clientSink client)
(sourceTMChan clientChan
$$ handleMessage server client
=$ appSink clientApp)
removeClient :: Server -> Client -> IO ()
removeClient server@Server{..} client@Client{..} = atomically $ do
modifyTVar' clients $ Map.delete clientName
broadcast server $ Notice (clientName <++> " has disconnected")
main :: IO ()
main = do
server <- newServer
runTCPServer (serverSettings 4000 "*") $ \app -> do
(fromClient, client) <-
appSource app $$+ readName server app `fuseUpstream` appSink app
print client
(runClient fromClient server client)
`finally` (removeClient server client)
@rtxanson

This comment has been minimized.

rtxanson commented Dec 30, 2014

I've been trying to learn how to get this to work using unicode (or well, accept unicode input on telnet, and return it), and I'm not sure exactly where to start. I'd love to know if you have any insight on that. It's hard to know where exactly, because the conduit-extra and conduit documentation seem to lack any meaningful examples using Unicode, rather just a ton of ascii.

edit: Nevermind, it's some encoding issue specific to telnet that I have to troubleshoot. Terminal is fine, tmux is fine, vim is fine, everything works with unicode (which I must use daily), just not telnet on my Mac. Telnet on a VPS is fine though, so I've confirmed it's not the code, it's me. ;)

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment