Ticket #5797: kill-recv-raw.hs

File kill-recv-raw.hs, 1.3 KB (added by joeyadams, 4 years ago)

Works incorrectly when compiled with -threaded on Windows

Line 
1import Control.Concurrent
2import Control.Exception
3import qualified Network as N
4import Network.Socket
5import System.IO
6
7seconds :: Int -> Int
8seconds = (* 1000000)
9
10connectClient :: IO Socket
11connectClient = do
12    localhost <- inet_addr "127.0.0.1"
13    sock <- socket AF_INET Stream defaultProtocol
14    connect sock $ SockAddrInet 1234 localhost
15    return sock
16
17main :: IO ()
18main = do
19    hSetBuffering stdout LineBuffering
20
21    _ <- forkIO $ do
22        sock <- N.listenOn $ N.PortNumber 1234
23        putStrLn "Listening on port 1234"
24        (h, host, port) <- N.accept sock
25        putStrLn $ "Accepted connection from " ++ host ++ ":" ++ show port
26        threadDelay $ seconds 10
27        hPutStrLn h "Don't garbage collect the server handle"
28
29    threadDelay $ seconds 2
30    putStrLn "Connecting to localhost:1234"
31    sock <- connectClient
32    putStrLn "Connected"
33
34    threadDelay $ seconds 2
35
36    tid <- forkIO $ do
37        putStrLn "recv"
38        _ <- recv sock 1 `onException`
39            putStrLn "Received exception during recv"
40        putStrLn "recv done"
41
42    threadDelay $ seconds 2
43    putStrLn "Killing line-getting thread (should return immediately)"
44    killThread tid
45    putStrLn "Done"
46    threadDelay $ seconds 2