blob: 54545b9b6212ab9e3318e2586d9d46fdc1ad2466 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
|
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
import Data.HList.TypeEqGeneric1()
import Data.HList.TypeCastGeneric1()
import ByteStringOperators
import Server
import Data.ByteString.Lazy.Char8 as L
( ByteString
, hPutStrLn
, init )
import System.IO
( Handle
)
import Control.Concurrent (forkIO)
import Control.Concurrent.Chan
import Data.HList
startCon socket st = do
let chan = hOccursFst st
nr = hOccursFst st :: ConnId
hdl = hOccursFst st :: Handle
quit = writeChan chan (nr,Nothing)
broadcast msg = writeChan chan (nr,Just msg)
chan' <- dupChan chan
reader <- forkIO $ fix $ \loop -> do
(nr', line) <- readChan chan'
case ( line, nr==nr') of
( Nothing , True ) -> Prelude.putStrLn "quit-client."
( Just msg , False ) -> hPutStrLn hdl msg >> loop
_ -> loop
hPutStrLn hdl "Hi, what's your name?"
line <- getPacket hdl
let name = L.init line
Prelude.putStrLn $ "readFst: " ++ show line
hPutStrLn hdl ("Welcome, " <++> name <++> "!")
broadcast ("--> " <++> name <++> " entered.")
return (name .*. ConnectionFinalizer quit .*. st)
doCon st bs cont = do
let hdl = hOccursFst st :: Handle
nr = hOccursFst st :: ConnId
chan = hOccursFst st
broadcast msg = writeChan chan (nr,Just msg)
name = hHead st
Prelude.putStrLn $ "read: " ++ show bs
case bs of
"quit\n" -> hPutStrLn hdl "Bye!"
_ -> do
broadcast (name <++> ": " <++> L.init bs)
cont ()
main = do
(chan :: Chan (ConnId, Maybe ByteString)) <- newChan
doServer (5222 .*. chan .*. HNil)
doCon
startCon
getLine
|
