基本`listenOn` HTTP服务器“接收失败：对等方重置连接”

Question

在深入研究 Haskell 的 Network 库时，我正在根据来自 this link 的信息制作一个非常简单的 HTTP 服务器。

import Control.Concurrent
import Control.Monad
import Network
import System.IO

main = withSocketsDo $ listenOn (PortNumber 8080) >>= loop

loop :: Socket -> IO ()
loop sock = do
  (h,_,_) <- accept sock
  forkIO $ handleRequest h
  loop sock

handleRequest :: Handle -> IO ()
handleRequest h = do
  hPutStr h $ httpRequest "Pong!\n"
  hFlush h
  hClose h

httpRequest :: String -> String
httpRequest body = "HTTP/1.0 200 OK\r\n"
  ++ "Content-Length: " ++ (show.length) body ++ "\r\n"
  ++ "\r\n" ++ body ++ "\r\n"

但是，即使我设法得到了一些响应，手柄似乎很快就会意外关闭（有时？），因为 curl 告诉我：

$ curl localhost:8080
Pong!
curl: (56) Recv failure: Connection reset by peer

注意：有时我什至没有收到消息 (Pong!) 或者只是其中的一部分。有时，它可以工作......但如果我连续运行 100 个curls，我最终会重置一些连接。

为什么会重置连接？我尝试使用和不使用forkIO 都没有成功。我错过了一些关于 Haskell 中 IO 流的基本信息吗？谢谢！

操作系统：最近的 Ubuntu； GHC：7.8.4

--- 编辑：---

jozefg 发现问题出在请求内容的耗尽上！但是，我想将此内容发送回客户端，但在使用以下代码时它会挂起：

handleRequest :: Handle -> IO ()
handleRequest h = do
  contents <- getHandleContents h
  hPutStr h $ httpRequest contents
  hFlush h
  hClose h

getHandleContents :: Handle -> IO String
getHandleContents h = do
  iseof <- hIsEOF h
  if iseof
    then return []
    else do
      newLine <- hGetLine h
      nextLines <- getHandleContents h
      return $ newLine ++ '\n' : nextLines

此外，我没有成功使用hGetContents 排出全部内容。知道为什么吗？

Answer 1

错误似乎是您没有完全读取客户端在发出 get-request 时发送的数据，如answer for Rust 中所述。提出的解决方案基本上是编写一个小循环，在您响应之前将标题从句柄中排出。 Haskell 版本是

drainHeaders :: Handle -> IO ()
drainHeaders h = do
  line <- hGetLine h
  if line == "\r" then return () else drainHeaders h

那么你的代码就可以写出来了

import Control.Concurrent
import Control.Exception (bracket)
import Control.Monad
import Network
import System.IO

main = withSocketsDo $
  bracket (listenOn (PortNumber 8080)) sClose loop

loop :: Socket -> IO ()
loop sock = do
  (handle, _host, _port) <- accept sock
  -- Handle is automatically closed now even in the face of async exns
  forkFinally (handleRequest handle) (const $ hClose handle)
  loop sock

drainHeaders :: Handle -> IO ()
drainHeaders h = do
  line <- hGetLine h -- Strips off a trailing \n
  if line == "\r" then return () else drainHeaders h

handleRequest :: Handle -> IO ()
handleRequest h = do
  drainHeaders h
  hPutStr h $ httpRequest "Pong!\n"
  hFlush h

httpRequest :: String -> String
httpRequest body =
  mconcat [ "HTTP/1.0 200 OK\r\nContent-Length: "
          , (show . length) body
          , "\r\n\r\n"
          , body
          , "\r\n" ]

我还冒昧地调整了代码，通过使用forkFinally 和bracket 来处理在面对异常时关闭的东西：我怀疑它是否 100% 完美，但现在有点更干净一点。