问题
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
回答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 Either
s, but that is just a limitation of how ArrowChoice
works.
回答2:
I have not run your code, but I think I spotted a problem.
routeRequest'' = runProxyK $ routeRequest''' <-< unitU
routeRequest'''
is requesting data from unitU which has nothing to supply, so it hangs.
:t runProxy $ unitU >-> printD
Will type check but nothing runs.
It seems like the data is being sent to the wrong level of the monad transformer, data which is flowing into routeRequest
should be flowing into routeRequest'''
. The data flowing into the wrong level of the monad transformer is what is probably causing you to need to leave of the type signature to get everything to type check. With the type signature routeRequest
is expecting a ()
coming from upstream and, I bet, with no type signature it is allowed to be polymorphic.
In your definition of routeRequest
you could "close the pipe", I think that is what it is called, by using unitD which would disallow your construction even when routeRequest'''
does not have the type signature.
来源:https://stackoverflow.com/questions/16205440/haskell-pipes-and-branching