Sockets 如何在Haskell中为localhost:3389编写开销最小的代理？

更新：问题现在包含最终编辑的答案

我现在使用以下最终答案：

module Main where

import Control.Concurrent        (forkIO)
import Control.Monad             (when,forever,void)
import Network                   (PortID(PortNumber),listenOn)
import Network.Socket hiding     (listen,recv,send)
import Network.Socket.ByteString (recv,sendAll)
import qualified Data.ByteString as B
import System

type Host = String
type Port = PortNumber

main :: IO ()
main = do
  [lp,h,p] <- getArgs  
  start (port lp) h (port p)
  where
    port = fromInteger . read

start :: Port -> Host -> Port -> IO ()
start lp rh rp = withSocketsDo $ do
  proxy <- listenOn $ PortNumber lp
  forever $ do
    (client,_) <- accept proxy
    void . forkIO $ (client >-<) =<< rh .@. rp

(.@.) :: Host -> Port -> IO Socket
host .@. port = do
  addr:_ <- getAddrInfo Nothing (Just host) (Just $ show port)
  server <- socket (addrFamily  addr) Stream defaultProtocol
  connect server   (addrAddress addr)
  return  server

(>-<) :: Socket -> Socket -> IO ()
x >-< y = do x >- y; y >- x

(>-) :: Socket -> Socket -> IO ()
s >- r = void . forkIO . handle $ forever stream
  where
    stream = recv s (64 * 1024) >>= ifNot0 >>= sendAll r
    ifNot0  = \c -> do when (B.null c) $ handle (error "0"); return c
    handle = flip catch $ \e -> print e >> sClose s >> sClose r

使用mRemote，如果我连接到localhost:2000，我会看到本地计算机的登录屏幕！：

*如果我找到改进>-甚至更进一步的方法，我将更新此答案

几个月前我刚开始与Haskell合作时发现的

这真的很简单，也很容易理解

编辑：基于以上要点，这里是一个经过测试的RDP代理。区别在于用sendAll替换send，以确保所有数据都已交付。在通过linux rdp服务器测试大型负载断开连接时发现此问题

module Main where

import Control.Concurrent      (forkIO)
import Control.Monad           (forever,unless)
import Network                 (PortID(PortNumber),listenOn)
import qualified Data.ByteString as S
import Network.Socket hiding (listen,recv,send)
import Network.Socket.ByteString (recv,sendAll)
import System.Posix            (Handler(Ignore),installHandler,sigPIPE)


localPort :: PortNumber
localPort = 3390

remoteHost :: String
remoteHost = "localhost"

remotePort :: Integer
remotePort = 3389

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 1024
        unless (S.null content) $ sendAll 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 ()

几个月前我开始和Haskell交往时发现的

这真的很简单，也很容易理解

编辑：基于以上要点，这里是一个经过测试的RDP代理。区别在于用sendAll替换send，以确保所有数据都已交付。在通过linux rdp服务器测试大型负载断开连接时发现此问题

module Main where

import Control.Concurrent      (forkIO)
import Control.Monad           (forever,unless)
import Network                 (PortID(PortNumber),listenOn)
import qualified Data.ByteString as S
import Network.Socket hiding (listen,recv,send)
import Network.Socket.ByteString (recv,sendAll)
import System.Posix            (Handler(Ignore),installHandler,sigPIPE)


localPort :: PortNumber
localPort = 3390

remoteHost :: String
remoteHost = "localhost"

remotePort :: Integer
remotePort = 3389

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 1024
        unless (S.null content) $ sendAll 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 ()

看来你是来找信息的。这个时候，是坏的，有点乱。在这种情况下，请毫不犹豫地与本案中的作者、我联系，以便他能够确定今后参考的要点：

我会尽快修复它并链接到这个问题。固定版本将包括sendAll以及来自此SO问题的所有好建议，因此请分享您的最佳想法。作为补充说明，已经有了sendAll补丁，以防有人感兴趣

编辑：要点现在已经确定了

看来你是在寻找信息时找到的。这个时候，是坏的，有点乱。在这种情况下，请毫不犹豫地与本案中的作者、我联系，以便他能够确定今后参考的要点：

我会尽快修复它并链接到这个问题。固定版本将包括sendAll以及来自此SO问题的所有好建议，因此请分享您的最佳想法。作为补充说明，已经有了sendAll补丁，以防有人感兴趣

---

---

编辑：要点现在已经解决了

你想用他的代码解决什么具体问题？@MikePennington，我刚才在问题的末尾描述了我想解决的问题。@Cetin Sert:那么你的问题是如何让这更快？@NiklasB。更快&而且使用尽可能少的内存，而不在>-中创建内容-我没有关于如何加快速度的好建议，但有两个关于风格的注释。忽略函数已在Control.Monad中可用，名称为void。另外//name不太具有描述性，我最好使用普通的sClose from>>sClose to。你想用他的代码解决什么具体问题？@MikePennington，我刚才在问题的末尾描述了我想解决的问题。@Cetin Sert:那么你的问题是如何让这个更快？@NiklasB。更快&而且使用尽可能少的内存，而不在>-中创建内容-我没有关于如何加快速度的好建议，但有两个关于风格的注释。忽略函数已在Control.Monad中可用，名称为void。另外//name不太具有描述性，我最好使用普通的sClose from>>sClose to。谢谢链接。事实上，我在问题中使用了相同的一个…，我的问题是关于proxyTo的效率，但我想我很快不会得到答案，或者很难改进它。修复了github的代码。它和你的代码有着同样的问题，吞噬数据流。谢谢你的链接。事实上，我在问题中使用了相同的一个…，我的问题是关于proxyTo的效率，但我想我很快不会得到答案，或者很难改进它。修复了github的代码。它与您的代码存在相同的问题，占用了数据流。我仍然需要跟上github的快节奏环境，因此Gist和Ping等概念超出了我当前的视野：。我很高兴这个要点现在能被修正。最简单的方法可能是在要点中添加一条评论，但不幸的是你必须为此登录。和许多人一样，我倾向于使用Gist粘贴代码，以便与同伴分享快速而肮脏的概念。因此，我的GIST和其他许多GIST几乎总是设计得很糟糕，而且很糟糕。这就是为什么如果一个搜索引擎碰巧索引了其中一个，并且有些人觉得它很有趣，那么让作者知道他的丑陋的黑客需要一点小心是非常重要的：48行代码，我们有一个工作可靠、低内存、高性能的可爱代理。代码非常清晰，它是一个真正的可执行的意识流，没有杂音，只有我所见过的最可爱的函数式编程语言的纯粹意图。我真的很高兴也很感激我偶然发现了你的要点比以前更短更切题：！我很高兴能对哈斯凯尔更广泛地接受花式符号负部分责任。我还需要赶上fast pac

---

github的ed环境，因此GIST和Ping等概念超出了我目前的视野：。我很高兴这个要点现在能被修正。最简单的方法可能是在要点中添加一条评论，但不幸的是你必须为此登录。和许多人一样，我倾向于使用Gist粘贴代码，以便与同伴分享快速而肮脏的概念。因此，我的GIST和其他许多GIST几乎总是设计得很糟糕，而且很糟糕。这就是为什么如果一个搜索引擎碰巧索引了其中一个，并且有些人觉得它很有趣，那么让作者知道他的丑陋的黑客需要一点小心是非常重要的：48行代码，我们有一个工作可靠、低内存、高性能的可爱代理。代码非常清晰，它是一个真正的可执行的意识流，没有杂音，只有我所见过的最可爱的函数式编程语言的纯粹意图。我真的很高兴也很感激我偶然发现了你的要点比以前更短更切题：！我很高兴能为哈斯克尔更广泛地接受花哨的符号承担部分责任。