1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
|
-- 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 (forever, void)
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
|
