/
paintserver.hs
140 lines (120 loc) · 3.3 KB
/
paintserver.hs
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
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
import Control.Concurrent
import Control.Concurrent.STM (atomically)
import Control.Concurrent.STM.TChan
import qualified Control.Exception as E
import Control.Monad
import Data.List
import qualified Data.Vector as V
import Network.Socket
import System.IO
import Text.Read
boardSize = (32, 32) :: (Int, Int)
boardDataSize = x * y
where
(x, y) = boardSize
data Pix
= Transparent
| Dark
| Light
deriving (Show, Read)
type Board = V.Vector Pix
newBoard = V.replicate boardDataSize Transparent
boardIdx ix iy = ix + x * iy
where
(x, _) = boardSize
boardXY idx = (idx `mod` x, idx `div` x)
where
(x, _) = boardSize
inBoard ix iy = ix >= 0 && ix < x && iy >= 0 && iy < y
where
(x, y) = boardSize
fieldChar Transparent = '.'
fieldChar Dark = 'o'
fieldChar Light = 'x'
boardPixel c ix iy b =
if inBoard ix iy
then b V.// [(idx, c)]
else b
where
idx = boardIdx ix iy
boardPrint b =
putStrLn "---" >>
forM_
[0 .. y - 1]
(\i -> putStrLn $ map fieldChar $ V.toList $ V.slice (x * i) x b)
where
(x, y) = boardSize
data InMsg
= DoPoll
| DoPix Pix Int Int
| DoTerminate
data OutMsg
= SetBoard (V.Vector Pix)
| SetPix Pix Int Int
data ServerCom =
ServerCom
{ inChan :: Chan InMsg
, outChan :: TChan OutMsg
}
newServerCom = ServerCom <$> newChan <*> newBroadcastTChanIO
workerThread :: ServerCom -> Board -> IO ()
workerThread com board = do
let continue b = workerThread com b
broadcast b = atomically $ writeTChan (outChan com) b
msg <- readChan (inChan com)
case msg of
DoPoll -> broadcast (SetBoard board) >> continue board
DoPix p x y -> broadcast (SetPix p x y) >> continue (boardPixel p x y board)
DoTerminate -> pure ()
main =
withSocketsDo $ do
com <- newServerCom
worker <- forkIO $ workerThread com newBoard
E.bracket open close $ mainLoop com
writeChan (inChan com) DoTerminate
where
open = do
sock <- socket AF_INET Stream 0
setSocketOption sock ReuseAddr 1
bind sock $ SockAddrInet 10042 0
listen sock 10
return sock
mainLoop com sock =
forever $ do
(c, _) <- accept sock
forkIO $ E.bracket (setupConn c) hClose $ runConn com
setupConn c = do
h <- socketToHandle c ReadWriteMode
hSetBuffering h NoBuffering
return h
runConn com h = do
myChan <- atomically $ dupTChan (outChan com)
let recvLoop = loop
where
loop = do
cmd <- words . filter (>= ' ') <$> hGetLine h --filter out \r sent by telnet
case cmd of
["Poll"] -> do
writeChan (inChan com) DoPoll
loop
[pix, p1, p2] -> do
let input =
DoPix <$> readMaybe pix <*> readMaybe p1 <*> readMaybe p2
maybe (hPutStrLn h "Error") (writeChan $ inChan com) input
loop
["Quit"] -> pure ()
[] -> loop
_ -> do
hPutStrLn h ("Error")
loop
let sendLoop =
forever $
do
x <- atomically $ readTChan myChan
case x of
SetBoard v -> hPutStrLn h $ "Paper " ++ map fieldChar (V.toList v)
SetPix p x y ->
hPutStrLn h $ intercalate " " [show p, show x, show y]
sender <- forkIO $ sendLoop
recvLoop
killThread sender