Haskell Pipes and Branching

Question

Problem

I'm attempting to implement a simple web server with Haskell and the Pipes library. I understand now that cyclic or diamond topologies aren't possible with pipes, however I thought that what I am trying to is. My desired topology is thus:

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

I have HTTPRequest RequestLine Headers Message and HTTPResponse StatusLine Headers Message types which are used in the chain. socketReadS takes bytes from the socket and forwards them to parseRequest, which uses Attoparsec to parse the bytes into an HTTPRequest object. I would then like the pipe to branch at least twice and possibly more depending on how many HTTP methods I implement. Each handle<method> function should receive HTTPRequest objects from upstream and forward HTTPResponse objects to packRequest, which simply packs up the HTTPResponse objects in a ByteString ready to be sent with socketWriteS.

The following code typechecks if I let GHC infer the type for routeRequest''' (mine seems to be slightly off somehow). However nothing seems to be executing after parseRequest. Can anyone help me figure out why?

Code

I have the following code for routeRequest which should handle the branching.

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 are implemented as such:

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

I have the following shorthands for proxies:

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

Finally, I run the whole thing like this:

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

The type signature of parseRequestProxy is this:

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

Edit

Here's the repository with the source code. Be warned it has not been prettied up so use at your own risk. https://bitbucket.org/Dwilson1234/haskell-web-server/overview

Answer 1

I was wrong when I originally said you could not handle diamond topologies. I later discovered a sensible way to do this using an ArrowChoice-like interface and included the solution in pipes-3.2.0 in the form of the leftD and rightD combinators. I'll explain how it works:

Instead of nesting proxy transformers, you wrap the result with a 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

Then you can selectively apply each handler to each branch and then merge the branches:

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

If you have more than two branches then you will have to nest Eithers, but that is just a limitation of how ArrowChoice works.