1 {-# LANGUAGE ScopedTypeVariables, OverloadedStrings #-} |
1 {-# LANGUAGE ScopedTypeVariables #-} |
2 module NetRoutines where |
2 module NetRoutines where |
3 |
3 |
|
4 import Network |
4 import Network.Socket |
5 import Network.Socket |
5 import System.IO |
6 import System.IO |
|
7 import Control.Concurrent |
6 import Control.Concurrent.Chan |
8 import Control.Concurrent.Chan |
|
9 import Control.Concurrent.STM |
7 import qualified Control.Exception as Exception |
10 import qualified Control.Exception as Exception |
8 import Data.Time |
11 import Data.Time |
9 import Control.Monad |
|
10 ----------------------------- |
12 ----------------------------- |
11 import CoreTypes |
13 import CoreTypes |
|
14 import ClientIO |
12 import Utils |
15 import Utils |
13 import RoomsAndClients |
|
14 |
16 |
15 acceptLoop :: Socket -> Chan CoreMessage -> IO () |
17 acceptLoop :: Socket -> Chan CoreMessage -> Int -> IO () |
16 acceptLoop servSock chan = forever $ do |
18 acceptLoop servSock coreChan clientCounter = do |
17 Exception.handle |
19 Exception.handle |
18 (\(_ :: Exception.IOException) -> putStrLn "exception on connect") $ |
20 (\(_ :: Exception.IOException) -> putStrLn "exception on connect") $ |
19 do |
21 do |
20 (sock, sockAddr) <- Network.Socket.accept servSock |
22 (socket, sockAddr) <- Network.Socket.accept servSock |
21 |
23 |
|
24 cHandle <- socketToHandle socket ReadWriteMode |
|
25 hSetBuffering cHandle LineBuffering |
22 clientHost <- sockAddr2String sockAddr |
26 clientHost <- sockAddr2String sockAddr |
23 |
27 |
24 currentTime <- getCurrentTime |
28 currentTime <- getCurrentTime |
25 |
29 |
26 sendChan' <- newChan |
30 sendChan <- newChan |
27 |
31 |
28 let newClient = |
32 let newClient = |
29 (ClientInfo |
33 (ClientInfo |
30 sendChan' |
34 nextID |
31 sock |
35 sendChan |
|
36 cHandle |
32 clientHost |
37 clientHost |
33 currentTime |
38 currentTime |
34 "" |
39 "" |
35 "" |
40 "" |
36 False |
41 False |
37 0 |
42 0 |
38 lobbyId |
43 0 |
39 0 |
44 0 |
40 False |
45 False |
41 False |
46 False |
42 False |
47 False |
43 undefined |
48 undefined |
44 undefined |
49 undefined |
45 ) |
50 ) |
46 |
51 |
47 writeChan chan $ Accept newClient |
52 writeChan coreChan $ Accept newClient |
|
53 |
|
54 forkIO $ clientRecvLoop cHandle coreChan nextID |
|
55 forkIO $ clientSendLoop cHandle coreChan sendChan nextID |
48 return () |
56 return () |
|
57 |
|
58 acceptLoop servSock coreChan nextID |
|
59 where |
|
60 nextID = clientCounter + 1 |