Problem

我正在尝试使用 Haskell 和 Pipes 库实现一个简单的 Web 服务器。我现在明白循环或菱形拓扑对于管道是不可能的，但我认为我正在尝试这样做。我想要的拓扑结构是：

                                 -GET--> handleGET >-> packRequest >-> socketWriteD
                                 |
socketReadS >-> parseRequest >-routeRequest
                                 |
                                 -POST-> handlePOST >-> packRequest >-> socketWriteD

I have HTTPRequest RequestLine Headers Message and HTTPResponse StatusLine Headers Message链中使用的类型。socketReadS从套接字获取字节并将它们转发到parseRequest，它使用 Attoparsec 将字节解析为HTTPRequest目的。然后，我希望管道至少分支两次，甚至可能更多，具体取决于我实现的 HTTP 方法的数量。每个handle<method>函数应该接收HTTPRequest来自上游和前方的对象HTTPResponse反对packRequest，它只是将 HTTPResponse 对象打包在一个ByteString准备发送socketWriteS.

如果我让 GHC 推断类型，以下代码将进行类型检查routeRequest'''（我的似乎有点偏离）。然而之后似乎没有任何执行parseRequest。谁能帮我弄清楚为什么？

Code

我有以下代码routeRequest它应该处理分支。

routeRequest''' ::
    (Monad m, Proxy p1, Proxy p2, Proxy p3)
    => () -> Consumer p1 HTTPRequest (Pipe p2 HTTPRequest HTTPRequest (Pipe p3 HTTPRequest HTTPRequest m)) r
routeRequest''' () = runIdentityP . hoist (runIdentityP . hoist runIdentityP) $ forever $ do
    httpReq <- request ()
    let method = getMethod httpReq
    let (URI uri) = getURI httpReq
    case method of
      GET -> lift $ respond httpReq
      POST -> lift $ lift $ respond httpReq

routeRequest'' = runProxyK $ routeRequest''' <-< unitU
routeRequest' socket = runProxyK $ raiseK (p4 socket <-< handleGET) <-< routeRequest''
routeRequest socket = (p4 socket <-< handlePOST) <-< (routeRequest' socket)

handleGET and handlePOST是这样实现的：

handleGET :: Proxy p => () -> p () HTTPRequest r ByteString IO r
handleGET () = runIdentityP $ do
    httpReq <- request ()
    let (URI uri) = getURI httpReq
    lift $ Prelude.putStrLn "GET"
    respond $ B.append (B.pack "GET ") uri


handlePOST :: Proxy p => () -> p () HTTPRequest r ByteString IO r
handlePOST () = runIdentityP $ do
    httpReq <- request ()
    let (URI uri) = getURI httpReq
    lift $ Prelude.putStrLn "POST"
    respond $ B.append (B.pack "POST ") uri

我对代理有以下简写：

p1 socket = socketReadS 32 socket
p2 = parseRequestProxy 
p4 socket = socketWriteD socket

最后，我像这样运行整个过程：

main = serveFork (Host "127.0.0.1") "8080" $
    \(socket, remoteAddr) -> do
        ret <- runProxy $ runEitherK $ p1 socket >-> printD >-> p2 >-> printD  >-> routeRequest socket 
        Prelude.putStrLn $ show ret

的类型签名parseRequestProxy这是：

parseRequestProxy
  :: (Monad m, Proxy p) =>
     ()
     -> Pipe
          (EitherP Control.Proxy.Attoparsec.Types.BadInput p)
          ByteString
          HTTPRequest
          m
          r

Edit

这是包含源代码的存储库。请注意，它尚未经过美化，因此使用风险需您自担。https://bitbucket.org/Dwilson1234/haskell-web-server/overview

当我最初说你无法处理菱形拓扑时，我错了。后来我发现了一种明智的方法来做到这一点ArrowChoice类似的界面并将解决方案包含在pipes-3.2.0的形式leftD and rightD组合器。我将解释它是如何工作的：

您可以用一个包装结果，而不是嵌套代理变压器Left or Right

routeRequest ::
    (Monad m, Proxy p)
    => () -> Pipe p HTTPRequest (Either HTTPRequest HTTPRequest) m r
routeRequest () = runIdentityP $ forever $ do
    httpReq <- request ()
    let method = getMethod httpReq
    let (URI uri) = getURI httpReq
    respond $ case method of
      GET  -> Left  httpReq
      POST -> Right httpReq

然后您可以有选择地将每个处理程序应用到每个分支，然后合并分支：

routeRequest >-> leftD handleGET >-> rightD handlePOST >-> mapD (either id id)
    :: (Monad m, Proxy p) => () -> Pipe p HTTPRequest ByteString IO r

如果你有两个以上的分支，那么你将不得不嵌套Eithers，但这只是限制ArrowChoice works.