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