1-- Test code for "threadWait: invalid argument (Bad file descriptor)"
2-- See https://ghc.haskell.org/trac/ghc/ticket/14621
3-- See https://github.com/haskell/network/issues/287
4--
5-- % runghc BadFileDescriptor.hs
6-- BadFileDescriptor.hs: threadWait: invalid argument (Bad file descriptor)
7module Main where
8
9import Control.Concurrent (forkIO)
10import Control.Monad (void, forever)
11import Network.Socket hiding (recv)
12import Network.Socket.ByteString (recv, sendAll)
13
14main :: IO ()
15main = do
16    let localhost = "localhost"
17        listenPort = "9876"
18        connectPort = "6789"
19    proxy localhost listenPort connectPort
20
21proxy :: HostName -> ServiceName -> ServiceName -> IO ()
22proxy localhost listenPort connectPort = do
23    fromClient <- serverSocket localhost listenPort
24    toServer <- clientSocket localhost connectPort
25    void $ forkIO $ relay toServer fromClient
26    relay fromClient toServer
27
28relay :: Socket -> Socket -> IO ()
29relay s1 s2 = forever $ do
30    payload <- recv s1 4096
31    sendAll s2 payload
32
33serverSocket :: HostName -> ServiceName -> IO Socket
34serverSocket host port = do
35    let hints = defaultHints {
36                addrFlags = [AI_PASSIVE]
37              , addrSocketType = Stream
38              }
39    addr:_ <- getAddrInfo (Just hints) (Just host) (Just port)
40    sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
41    bind sock (addrAddress addr)
42    listen sock 1
43    fst <$> accept sock
44
45clientSocket :: HostName -> ServiceName -> IO Socket
46clientSocket host port = do
47    let hints = defaultHints { addrSocketType = Stream }
48    addr:_ <- getAddrInfo (Just hints) (Just host) (Just port)
49    sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
50    connect sock (addrAddress addr)
51    return sock
52