在深入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!)或只是其中的一部分。有时,它会起作用…但如果我连续运行100curls,我最终会得到一些连接重置。
为什么要重置连接?我试过和没有试过都没有成功。我错过了一些关于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

此外,我没有成功地使用forkIO排出全部内容。知道为什么吗?

最佳答案

错误似乎是您没有完全读取客户机发出get请求时发送的数据,如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" ]

我还冒昧地调整了代码,使用forkFinallybracket处理异常情况下的关闭操作,使其更安全一些:我怀疑它是100%完美的,但现在有点干净了。

10-05 21:13
查看更多