author | sheepluva |
Thu, 01 Apr 2010 23:37:28 +0000 | |
changeset 3246 | ab99a0f0b485 |
parent 2867 | 9be6693c78cb |
child 3425 | ead2ed20dfd4 |
permissions | -rw-r--r-- |
2348 | 1 |
{-# LANGUAGE ScopedTypeVariables #-} |
1804 | 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 |
|
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 |
|
14 |
import ClientIO |
|
1917 | 15 |
import Utils |
1804 | 16 |
|
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 |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2403
diff
changeset
|
22 |
(socket, sockAddr) <- Network.Socket.accept servSock |
1804 | 23 |
|
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2403
diff
changeset
|
24 |
cHandle <- socketToHandle socket ReadWriteMode |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2403
diff
changeset
|
25 |
hSetBuffering cHandle LineBuffering |
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 |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2403
diff
changeset
|
29 |
|
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2403
diff
changeset
|
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 |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2403
diff
changeset
|
34 |
nextID |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2403
diff
changeset
|
35 |
sendChan |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2403
diff
changeset
|
36 |
cHandle |
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 |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2403
diff
changeset
|
43 |
0 |
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 |
|
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2403
diff
changeset
|
52 |
writeChan coreChan $ Accept newClient |
1804 | 53 |
|
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2403
diff
changeset
|
54 |
forkIO $ clientRecvLoop cHandle coreChan nextID |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2403
diff
changeset
|
55 |
forkIO $ clientSendLoop cHandle coreChan sendChan nextID |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2403
diff
changeset
|
56 |
return () |
1804 | 57 |
|
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2403
diff
changeset
|
58 |
acceptLoop servSock coreChan nextID |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2403
diff
changeset
|
59 |
where |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2403
diff
changeset
|
60 |
nextID = clientCounter + 1 |