Ticket #5797: threadWaitRead.hs

File threadWaitRead.hs, 2.1 KB (added by joeyadams, 2 years ago)

threadWaitRead does something on Windows, but I don't know what

Line 
1import Prelude hiding (catch, log)
2
3import Control.Concurrent
4import Control.Concurrent.STM
5import Control.Exception
6import Network.Socket
7import System.IO
8
9waitFor :: TVar Bool -> IO ()
10waitFor var = atomically $ do
11    x <- readTVar var
12    case x of
13        False -> retry
14        True  -> return ()
15
16server :: TVar Bool -> IO ()
17server ready = do
18    let log msg = hPutStrLn stderr $ "server: " ++ msg
19
20    sock <- socket AF_INET Stream defaultProtocol
21    bindSocket sock $ SockAddrInet 1234 iNADDR_ANY
22    listen sock 5
23
24    atomically $ writeTVar ready True
25
26    log "Listening on port 1234"
27    (client_sock, client_addr) <- accept sock
28    log $ "Accepted connection from " ++ show client_addr
29
30    threadDelay 3000000
31    log "Sending \"Hi\" to the client"
32    _ <- send client_sock "Hi"
33    log "\"Hi\" sent"
34    return ()
35
36client :: IO ()
37client = do
38    let log msg = hPutStrLn stderr $ "client: " ++ msg
39
40    sock <- socket AF_INET Stream defaultProtocol
41    addr <- SockAddrInet 1234 `fmap` inet_addr "127.0.0.1"
42
43    log $ "client: Connecting to " ++ show addr
44    connect sock addr
45
46    mask_ $ do
47        log "Connected.  Waiting for data..."
48
49        -- When run with -threaded on Windows, this does not wake up when the
50        -- server sends data, but it can be killed by an asynchronous
51        -- exception.
52        let MkSocket fd _ _ _ _ = sock
53         in threadWaitRead $ fromIntegral fd
54
55        -- If I do this instead, it unblocks when the server sends data, but
56        -- not when an asynchronous exception is received.
57        -- _ <- recv sock 1
58
59        uninterruptibleMask_ $
60            log "Done waiting for data"
61
62main :: IO ()
63main = do
64    let log msg = hPutStrLn stderr $ "main: " ++ msg
65
66    hSetBuffering stdout LineBuffering
67    hSetBuffering stderr LineBuffering
68
69    ready <- newTVarIO False
70
71    log "Starting server"
72    _ <- forkIO $ server ready
73    waitFor ready
74
75    log "Starting client"
76    client_tid <- forkIO client
77
78    threadDelay 5000000
79    log "Killing client"
80    killThread client_tid
81
82    log "Client killed"