author | koda |
Tue, 01 Feb 2011 15:30:08 +0100 | |
changeset 4900 | 8ad0e23e6d63 |
parent 4568 | f85243bf890e |
child 4905 | 7842d085acf4 |
permissions | -rw-r--r-- |
4568 | 1 |
{-# LANGUAGE ScopedTypeVariables #-} |
1804 | 2 |
module NetRoutines where |
3 |
||
4568 | 4 |
import Network |
1804 | 5 |
import Network.Socket |
6 |
import System.IO |
|
4568 | 7 |
import Control.Concurrent |
1804 | 8 |
import Control.Concurrent.Chan |
4568 | 9 |
import Control.Concurrent.STM |
2296
19f2f76dc346
Patch for compiling with 6.10 (define NEW_EXCEPTIONS to do that)
unc0rr
parents:
2245
diff
changeset
|
10 |
import qualified Control.Exception as Exception |
1804 | 11 |
import Data.Time |
12 |
----------------------------- |
|
13 |
import CoreTypes |
|
4568 | 14 |
import ClientIO |
1917 | 15 |
import Utils |
1804 | 16 |
|
4568 | 17 |
acceptLoop :: Socket -> Chan CoreMessage -> Int -> IO () |
18 |
acceptLoop servSock coreChan clientCounter = do |
|
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2403
diff
changeset
|
19 |
Exception.handle |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2403
diff
changeset
|
20 |
(\(_ :: Exception.IOException) -> putStrLn "exception on connect") $ |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2403
diff
changeset
|
21 |
do |
4568 | 22 |
(socket, sockAddr) <- Network.Socket.accept servSock |
1804 | 23 |
|
4568 | 24 |
cHandle <- socketToHandle socket ReadWriteMode |
25 |
hSetBuffering cHandle LineBuffering |
|
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2403
diff
changeset
|
26 |
clientHost <- sockAddr2String sockAddr |
1804 | 27 |
|
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2403
diff
changeset
|
28 |
currentTime <- getCurrentTime |
4568 | 29 |
|
30 |
sendChan <- newChan |
|
1804 | 31 |
|
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2403
diff
changeset
|
32 |
let newClient = |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2403
diff
changeset
|
33 |
(ClientInfo |
4568 | 34 |
nextID |
35 |
sendChan |
|
36 |
cHandle |
|
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2403
diff
changeset
|
37 |
clientHost |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2403
diff
changeset
|
38 |
currentTime |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2403
diff
changeset
|
39 |
"" |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2403
diff
changeset
|
40 |
"" |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2403
diff
changeset
|
41 |
False |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2403
diff
changeset
|
42 |
0 |
4568 | 43 |
0 |
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2403
diff
changeset
|
44 |
0 |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2403
diff
changeset
|
45 |
False |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2403
diff
changeset
|
46 |
False |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2403
diff
changeset
|
47 |
False |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2403
diff
changeset
|
48 |
undefined |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2403
diff
changeset
|
49 |
undefined |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2403
diff
changeset
|
50 |
) |
1804 | 51 |
|
4568 | 52 |
writeChan coreChan $ Accept newClient |
53 |
||
54 |
forkIO $ clientRecvLoop cHandle coreChan nextID |
|
55 |
forkIO $ clientSendLoop cHandle coreChan sendChan nextID |
|
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2403
diff
changeset
|
56 |
return () |
4568 | 57 |
|
58 |
acceptLoop servSock coreChan nextID |
|
59 |
where |
|
60 |
nextID = clientCounter + 1 |