paul-r-ml · December 12, 2010 13:06 · Mar 2, 2012 · Mar 2, 2012 · Dec 12, 2010
diff --git a/haskellTcpProxy.hs b/haskellTcpProxy.hs
@@ -1,10 +1,11 @@
 module Main where
 
 import Control.Concurrent      (forkIO)
-import Control.Monad           (forever)
+import Control.Monad           (forever, unless)
 import Network                 (PortID(PortNumber),listenOn)
 import Network.Socket hiding (listen,recv,send)
 import Network.Socket.ByteString (recv,sendAll)
+import qualified Data.ByteString as S
 import System.Posix            (Handler(Ignore),installHandler,sigPIPE)
 
 data Setting = Setting { locPort :: PortNumber , remHost :: String, remPort :: String }
@@ -25,7 +26,9 @@ main = installHandler sigPIPE Ignore Nothing >> do
       (servAddr:_) <- getAddrInfo Nothing (Just $ remHost setting) (Just $ remPort setting)
       server <- socket (addrFamily servAddr) Stream defaultProtocol
       connect server (addrAddress servAddr) >> return server
-    p1 <~~> p2      = ignore $ (p1 `proxyTo` p2) >> (p2 `proxyTo` p1)
-    proxyTo from to = forkIO $ closing from to $ forever $ recv from 4096 >>= sendAll to
-    closing a b     = flip catch (const $ sClose a >> sClose b)
+    p1 <~~> p2      = ignore $ forkIO (p1 `proxyTo` p2) >> forkIO (p2 `proxyTo` p1)
+    proxyTo from to = flip catch (const $ sClose from >> sClose to) $ mapData from to
+    mapData from to = do
+      content <- recv from 4096 
+      unless (S.null content) $ sendAll to content >> mapData from to
     ignore x        = x >> return ()
diff --git a/haskellTcpProxy.hs b/haskellTcpProxy.hs
@@ -4,49 +4,28 @@ import Control.Concurrent      (forkIO)
 import Control.Monad           (forever)
 import Network                 (PortID(PortNumber),listenOn)
 import Network.Socket hiding (listen,recv,send)
-import Network.Socket.ByteString (recv,send)
+import Network.Socket.ByteString (recv,sendAll)
 import System.Posix            (Handler(Ignore),installHandler,sigPIPE)
 
-localPort :: PortNumber
-localPort = 8000
+data Setting = Setting { locPort :: PortNumber , remHost :: String, remPort :: String }
 
-remoteHost :: String
-remoteHost = "ftp.free.fr"
-
-remotePort :: Integer
-remotePort = 80
+setting :: Setting
+setting = Setting 9900 "ftp.free.fr" "80"
 
 main :: IO ()
-main = do
-  ignore $ installHandler sigPIPE Ignore Nothing
-  start
-
-start :: IO ()
-start = withSocketsDo $ do
-  listener <- listenOn $ PortNumber localPort
-  forever $ do
-    (client,_) <- accept listener
-    ignore $ forkIO $ do
-      server <- connectToServer
-      client `proxyTo` server
-      server `proxyTo` client
-    return ()
+main = installHandler sigPIPE Ignore Nothing >> do
+  withSocketsDo $ do
+    listener <- listenOn $ PortNumber (locPort setting)
+    forever $ accept listener >>= \(client,_) -> 
+      ignore $ forkIO $ do 
+        server <- getServerSocket
+        client <~~> server
   where
-    connectToServer = do
-      addrinfos <- getAddrInfo Nothing (Just remoteHost) (Just $ show remotePort)
-      let serveraddr = head addrinfos
-      server <- socket (addrFamily serveraddr) Stream defaultProtocol
-      connect server (addrAddress serveraddr)
-      return server
-    proxyTo from to = do
-      ignore $ forkIO $ flip catch (close from to) $ forever $ do
-        content <- recv from 4096
-        ignore $ send to content
-      return ()
-    close a b _ = do
-      sClose a
-      sClose b
-
--- | Run an action and ignore the result.
-ignore :: Monad m => m a -> m ()
-ignore m = m >> return ()
+    getServerSocket = do
+      (servAddr:_) <- getAddrInfo Nothing (Just $ remHost setting) (Just $ remPort setting)
+      server <- socket (addrFamily servAddr) Stream defaultProtocol
+      connect server (addrAddress servAddr) >> return server
+    p1 <~~> p2      = ignore $ (p1 `proxyTo` p2) >> (p2 `proxyTo` p1)
+    proxyTo from to = forkIO $ closing from to $ forever $ recv from 4096 >>= sendAll to
+    closing a b     = flip catch (const $ sClose a >> sClose b)
+    ignore x        = x >> return ()
diff --git a/haskellTcpProxy.hs b/haskellTcpProxy.hs
@@ -0,0 +1,52 @@
+module Main where
+
+import Control.Concurrent      (forkIO)
+import Control.Monad           (forever)
+import Network                 (PortID(PortNumber),listenOn)
+import Network.Socket hiding (listen,recv,send)
+import Network.Socket.ByteString (recv,send)
+import System.Posix            (Handler(Ignore),installHandler,sigPIPE)
+
+localPort :: PortNumber
+localPort = 8000
+
+remoteHost :: String
+remoteHost = "ftp.free.fr"
+
+remotePort :: Integer
+remotePort = 80
+
+main :: IO ()
+main = do
+  ignore $ installHandler sigPIPE Ignore Nothing
+  start
+
+start :: IO ()
+start = withSocketsDo $ do
+  listener <- listenOn $ PortNumber localPort
+  forever $ do
+    (client,_) <- accept listener
+    ignore $ forkIO $ do
+      server <- connectToServer
+      client `proxyTo` server
+      server `proxyTo` client
+    return ()
+  where
+    connectToServer = do
+      addrinfos <- getAddrInfo Nothing (Just remoteHost) (Just $ show remotePort)
+      let serveraddr = head addrinfos
+      server <- socket (addrFamily serveraddr) Stream defaultProtocol
+      connect server (addrAddress serveraddr)
+      return server
+    proxyTo from to = do
+      ignore $ forkIO $ flip catch (close from to) $ forever $ do
+        content <- recv from 4096
+        ignore $ send to content
+      return ()
+    close a b _ = do
+      sClose a
+      sClose b
+
+-- | Run an action and ignore the result.
+ignore :: Monad m => m a -> m ()
+ignore m = m >> return ()