|
1 {-# LANGUAGE PatternSignatures #-} |
|
2 module NetRoutines where |
|
3 |
|
4 import Network |
|
5 import Network.Socket |
|
6 import System.IO |
|
7 import Control.Concurrent |
|
8 import Control.Concurrent.Chan |
|
9 import Control.Concurrent.STM |
|
10 import Control.Exception |
|
11 import Data.Time |
|
12 ----------------------------- |
|
13 import CoreTypes |
|
14 import ClientIO |
|
15 |
|
16 sockAddr2String :: SockAddr -> IO String |
|
17 sockAddr2String (SockAddrInet _ hostAddr) = inet_ntoa hostAddr |
|
18 sockAddr2String (SockAddrInet6 _ _ (a, b, c, d) _) = return (foldr1 (\a b -> a ++ ":" ++ b) [show a, show b, show c, show d]) |
|
19 |
|
20 acceptLoop :: Socket -> Chan CoreMessage -> Int -> IO () |
|
21 acceptLoop servSock coreChan clientCounter = do |
|
22 Control.Exception.handle |
|
23 (\(_ :: Exception) -> putStrLn "exception on connect") $ |
|
24 do |
|
25 (socket, sockAddr) <- Network.Socket.accept servSock |
|
26 |
|
27 cHandle <- socketToHandle socket ReadWriteMode |
|
28 hSetBuffering cHandle LineBuffering |
|
29 clientHost <- sockAddr2String sockAddr |
|
30 |
|
31 currentTime <- getCurrentTime |
|
32 putStrLn $ (show currentTime) ++ " new client id: " ++ (show nextID) |
|
33 |
|
34 sendChan <- newChan |
|
35 |
|
36 let newClient = |
|
37 (ClientInfo |
|
38 nextID |
|
39 sendChan |
|
40 cHandle |
|
41 clientHost |
|
42 --currentTime |
|
43 "" |
|
44 0 |
|
45 0 |
|
46 False |
|
47 False |
|
48 False |
|
49 False) |
|
50 |
|
51 writeChan coreChan $ Accept newClient |
|
52 |
|
53 forkIO $ clientRecvLoop cHandle coreChan nextID |
|
54 forkIO $ clientSendLoop cHandle coreChan sendChan nextID |
|
55 return () |
|
56 |
|
57 yield -- hm? |
|
58 acceptLoop servSock coreChan nextID |
|
59 where |
|
60 nextID = clientCounter + 1 |