Ticket #5797: threadWaitRead.hs

import Prelude hiding (catch, log)

import Control.Concurrent
import Control.Concurrent.STM
import Control.Exception
import Network.Socket
import System.IO

waitFor :: TVar Bool -> IO ()
waitFor var = atomically $ do
    x <- readTVar var
    case x of
        False -> retry
        True  -> return ()

server :: TVar Bool -> IO ()
server ready = do
    let log msg = hPutStrLn stderr $ "server: " ++ msg

    sock <- socket AF_INET Stream defaultProtocol
    bindSocket sock $ SockAddrInet 1234 iNADDR_ANY
    listen sock 5

    atomically $ writeTVar ready True

    log "Listening on port 1234"
    (client_sock, client_addr) <- accept sock
    log $ "Accepted connection from " ++ show client_addr

    threadDelay 3000000
    log "Sending \"Hi\" to the client"
    _ <- send client_sock "Hi"
    log "\"Hi\" sent"
    return ()

client :: IO ()
client = do
    let log msg = hPutStrLn stderr $ "client: " ++ msg

    sock <- socket AF_INET Stream defaultProtocol
    addr <- SockAddrInet 1234 `fmap` inet_addr "127.0.0.1"

    log $ "client: Connecting to " ++ show addr
    connect sock addr

    mask_ $ do
        log "Connected.  Waiting for data..."

        -- When run with -threaded on Windows, this does not wake up when the
        -- server sends data, but it can be killed by an asynchronous
        -- exception.
        let MkSocket fd _ _ _ _ = sock
         in threadWaitRead $ fromIntegral fd

        -- If I do this instead, it unblocks when the server sends data, but
        -- not when an asynchronous exception is received.
        -- _ <- recv sock 1

        uninterruptibleMask_ $
            log "Done waiting for data"

main :: IO ()
main = do
    let log msg = hPutStrLn stderr $ "main: " ++ msg

    hSetBuffering stdout LineBuffering
    hSetBuffering stderr LineBuffering

    ready <- newTVarIO False

    log "Starting server"
    _ <- forkIO $ server ready
    waitFor ready

    log "Starting client"
    client_tid <- forkIO client

    threadDelay 5000000
    log "Killing client"
    killThread client_tid

    log "Client killed"