Haskell 管道和分支

Question

问题

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

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

我有 HTTPRequest RequestLine Headers Message 和 HTTPResponse StatusLine Headers Message 在链中使用的类型。 socketReadS 从套接字中获取字节并将它们转发给 parseRequest，后者使用 Attoparsec 将字节解析为 HTTPRequest 对象。然后，我希望管道至少分支两次，并且可能更多，这取决于我实现了多少 HTTP 方法。每个handle<method> 函数应该从上游接收HTTPRequest 对象并将HTTPResponse 对象转发到packRequest，这只是将HTTPResponse 对象打包在ByteString 中，准备好与socketWriteS 一起发送。

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

代码

我有以下 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 和 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

编辑

这是包含源代码的存储库。请注意，它没有经过修饰，因此使用风险自负。 https://bitbucket.org/Dwilson1234/haskell-web-server/overview

Answer 1

我最初说您无法处理菱形拓扑时我错了。后来我发现了一种使用类似ArrowChoice 的接口来执行此操作的明智方法，并将解决方案以leftD 和rightD 组合器的形式包含在pipes-3.2.0 中。我将解释它是如何工作的：

您使用Left 或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 工作方式的限制。

Answer 2

我没有运行你的代码，但我想我发现了一个问题。

routeRequest'' = runProxyK $ routeRequest''' <-< unitU

routeRequest''' 正在向 unitU 请求数据，但它没有提供任何东西，所以它挂起。

:t runProxy $ unitU >-> printD

将键入检查，但没有运行。

似乎数据被发送到 monad 转换器的错误级别，流入routeRequest 的数据应该流入routeRequest'''。流入 monad 转换器错误级别的数据可能导致您需要离开类型签名以获取所有内容以进行类型检查。使用类型签名routeRequest 期待来自上游的()，我敢打赌，如果没有类型签名，它可以是多态的。

在您对routeRequest 的定义中，您可以“关闭管道”，我认为这就是所谓的，通过使用 unitD 即使routeRequest''' 没有类型签名也会禁止您的构造。