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 curl，我最终会重置一些连接。

为什么重置连接？我在没有成功的情况下尝试了forkIO。我是否错过了Haskell中关于IO流的一些基本要素？谢谢！

OS：最近的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％完美但是它现在有点清洁了。

基本`listenOn` HTTP服务器“Recv failure：peer reset by peer”

1 个答案: