network-2.6.3.4: tests/BadFileDescriptor.hs

-- Test code for "threadWait: invalid argument (Bad file descriptor)"
-- See https://ghc.haskell.org/trac/ghc/ticket/14621
-- See https://github.com/haskell/network/issues/287
--
-- % runghc BadFileDescriptor.hs
-- BadFileDescriptor.hs: threadWait: invalid argument (Bad file descriptor)
module Main where

import Control.Concurrent (forkIO)
import Control.Monad (void, forever)
import Network.Socket hiding (recv)
import Network.Socket.ByteString (recv, sendAll)

main :: IO ()
main = do
    let localhost = "localhost"
        listenPort = "9876"
        connectPort = "6789"
    proxy localhost listenPort connectPort

proxy :: HostName -> ServiceName -> ServiceName -> IO ()
proxy localhost listenPort connectPort = do
    fromClient <- serverSocket localhost listenPort
    toServer <- clientSocket localhost connectPort
    void $ forkIO $ relay toServer fromClient
    relay fromClient toServer

relay :: Socket -> Socket -> IO ()
relay s1 s2 = forever $ do
    payload <- recv s1 4096
    sendAll s2 payload

serverSocket :: HostName -> ServiceName -> IO Socket
serverSocket host port = do
    let hints = defaultHints {
                addrFlags = [AI_PASSIVE]
              , addrSocketType = Stream
              }
    addr:_ <- getAddrInfo (Just hints) (Just host) (Just port)
    sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
    bind sock (addrAddress addr)
    listen sock 1
    fst <$> accept sock

clientSocket :: HostName -> ServiceName -> IO Socket
clientSocket host port = do
    let hints = defaultHints { addrSocketType = Stream }
    addr:_ <- getAddrInfo (Just hints) (Just host) (Just port)
    sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
    connect sock (addrAddress addr)
    return sock