HBridge.hs

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
53
54
55
56
57
58
module HBridge where

import Control.Applicative
import Control.Concurrent
import Control.Exception
import Control.Monad
import qualified Data.ByteString as StrictB
import qualified Data.ByteString.Lazy as LazyB
import Data.Monoid
import Network
import System.IO


strictBridge                ::  Handle -> Handle -> IO ()
strictBridge a b             =  forever (flush a b >> flush b a)
 where
  flush a b                  =  do
    bytes                   <-  readAllNonBlocking a
    putStrLn =<< handleMessage a b
    StrictB.hPut b bytes
  readAllNonBlocking h       =  do
    hWaitForInput h (-1) -- Wait forever.
    loop mempty
   where
    loop bytes               =  do
      bytes'                <-  StrictB.hGetNonBlocking h 0x1000
      ready                 <-  hReady h
      (if ready then loop else return) (mappend bytes bytes')

lazyBridge                  ::  Handle -> Handle -> IO ()
lazyBridge a b               =  forever (flush a b >> flush b a)
 where
  flush a b                  =  do
    bytes                   <-  LazyB.hGetContents a
    putStrLn =<< handleMessage a b
    LazyB.hPut b bytes

handleMessage a b            =  template <$> hShow a <*> hShow b
 where
  template x y               =  x ++ "\n -->>>> " ++ y

proxy :: PortID -> PortID -> (Handle -> Handle -> IO())-> IO ()
proxy source dest bridge     =  do
  socket                    <-  listenOn source
  finally (acceptLoop socket) (sClose socket)
 where
  acceptLoop listenSocket    =  do
    (conn, _, _)            <-  accept listenSocket
    _                       <-  forkIO (connection conn)
    acceptLoop listenSocket
  connection conn            =  do
    condition conn
    conn'                   <-  connectTo "localhost" dest
    condition conn'
    bridge conn conn'
  condition handle           =  do hSetBuffering handle NoBuffering
                                   hSetBinaryMode handle True