Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
branch: master
Fetching contributors…

Cannot retrieve contributors at this time

145 lines (138 sloc) 7.136 kb
module Lobby ( lobby, lobbyClient ) where
import TCP.Client ( Client, ioClient, forkClient )
import TCP.ServerTypes ( Server, ServerMessage(N,M),
ioServer, forkServer )
import TCP.Chan ( ShowRead, writeOutput, readInput, pipe, readLine )
import TCP.Message ( Message(..) )
import Data.Maybe ( fromJust )
import Control.Monad ( forever )
import Control.Concurrent ( forkIO )
data LobbyMsg tablename tablemsg = Chat String
| JoinTable tablename
| TableMsg tablename tablemsg
deriving ( Eq, Show, Read )
instance (ShowRead name, ShowRead msg) => ShowRead (LobbyMsg name msg)
data LobbyClient name tablename tablemsg
= Chatted name String
| JoinedTable name tablename
| AtTable tablename tablemsg
| Joined name
deriving ( Eq, Show, Read )
instance (ShowRead name, ShowRead tablename, ShowRead msg) =>
ShowRead (LobbyClient name tablename msg)
lobby :: (Eq name, ShowRead name,
Eq tablename, ShowRead tablename,
ShowRead toclient, ShowRead toserver) =>
tablename -> -- hokey trick to define tablename type...
Server name toclient (ServerMessage toserver)
-> Server name (LobbyClient name tablename toclient)
(ServerMessage (LobbyMsg tablename toserver))
lobby _ mktable = ioServer $ \o i ->
do let handle us ts =
do let sendToOthers m =
mapM_ (\t ->
if t /= fromAgent m
then writeOutput o (m { toAgent = t })
else return ()) us
sendToAll m =
mapM_ (\t -> writeOutput o (m { fromAgent= toAgent m,
toAgent = t })) us
m <- readInput i
case m of
Message f t N ->
do putStrLn (show f++" joined!")
-- the following message is probably ignored...
writeOutput o (Message f f (Joined f))
sendToAll (Message f t (Joined f))
handle (f:filter (/= f) us) ts
Message f t (M (Chat c)) ->
do putStrLn (show f++" says "++c)
sendToOthers (Message f t (Chatted f c))
handle us ts
Message f t (M (JoinTable tab)) ->
case lookup tab ts of
Just table ->
do writeOutput table (Message f t N)
writeOutput o (Message f f (JoinedTable f tab))
sendToAll (Message f t (JoinedTable f tab))
handle us ts
Nothing ->
do putStrLn ("creating table "++show tab)
(ii,oo) <- forkServer mktable
-- Any messages emerging from the
-- table get wrapped up with a table
-- label and forwarded to the
-- clients.
forkIO $ forever $
do Message f' t' x <- readInput ii
writeOutput o
(Message f' t' (AtTable tab x))
writeOutput oo (Message f t N)
writeOutput o (Message f f (JoinedTable f tab))
sendToAll (Message f t (JoinedTable f tab))
handle us ((tab,oo):ts)
Message f t (M (TableMsg tab mm)) ->
case lookup tab ts of
Just table ->
do putStrLn $ "passing message "++show mm++
" to table "++ show tab
writeOutput table (Message f t (M mm))
handle us ts
Nothing ->
do putStrLn "BOGUS MESSAGE!!!"
handle us ts
handle [] []
lobbyClient :: (Eq tablename, ShowRead tablename,
ShowRead toclient, ShowRead toserver) =>
tablename -> Client toclient toserver
-> Client (LobbyClient String tablename toclient)
(LobbyMsg tablename toserver)
lobbyClient _ dotable = ioClient $ \i o ->
do -- Don't grab stdin until *after* we've gotten one input over
-- the chan. This gives any modifiers a chance to get some
-- input first.
--
-- I'm telling it to ignore the first message, so it had better
-- be an awknowledgement message.
Joined me <- readInput i
putStrLn ("My name is "++show me)
(tablei, tableo) <- pipe
let dumpout mytab@(Just (mytable, tableout)) =
do m <- readInput i
case m of
Chatted _ _ -> dumpout mytab
JoinedTable _ _ -> dumpout mytab
Joined _ -> dumpout mytab
AtTable t x | t == mytable ->
do writeOutput tableout x
dumpout mytab
| otherwise -> dumpout mytab
dumpout Nothing =
do m <- readInput i
case m of
Chatted name mm ->
do putStrLn (show name++" says "++mm)
dumpout Nothing
JoinedTable n t
| n == me ->
do putStrLn ("I joined table "++show t)
tchan <- readInput tablei
dumpout (Just (t, tchan))
| otherwise ->
do putStrLn (show n++" joined "++show t)
dumpout Nothing
Joined n ->
do putStrLn (show n++" has joined us.")
dumpout Nothing
AtTable _ _ -> dumpout Nothing
forkIO $ dumpout Nothing
forever $ do x <- getLine
if take 5 x == "join "
then do let tname = fromJust $ readLine (drop 5 x)
writeOutput o (JoinTable tname)
(ii,oo) <- forkClient dotable
-- send the output chan to the other thread
writeOutput tableo oo
forever $ do m <- readInput ii
writeOutput o (TableMsg tname m)
else writeOutput o (Chat x)
Jump to Line
Something went wrong with that request. Please try again.