A minimalist reverse HTTP proxy using conduit

reverse-proxy.hs

{-# LANGUAGE OverloadedStrings #-}
import Data.Conduit
import Data.Conduit.List (peek)
import Data.Conduit.Network
import qualified Data.ByteString.Char8 as S8
import Data.Char (toLower, isSpace)
import Network (withSocketsDo)
import Control.Monad.IO.Class
import Control.Concurrent (forkIO)
import Network.Wai
import Network.Wai.Handler.Warp
import Network.HTTP.Types

hosts =
    [ ("localhost:5000", 5001)
    ]

someapp _ = return $ responseLBS status200 [("content-type", "text/plain")] "this is someapp"

main = withSocketsDo $ do
    forkIO $ run 5001 someapp
    proxy

proxy = runTCPServer (ServerSettings 5000 (Host "127.0.0.1"))
  $ \fromClient toClient -> do
    liftIO $ putStrLn "Received connection"
    (rsrc, mvhost) <- fromClient $$+ getVhost
    case mvhost of
        Nothing -> yield "HTTP/1.1 200 OK\r\nContent-type: text/plain\r\n\r\nNo virtual host specified" $$ toClient
        Just vhost ->
            case lookup vhost hosts of
                Nothing -> yield ("HTTP/1.1 200 OK\r\nContent-type: text/plain\r\n\r\nUnknown host: " `S8.append` vhost) $$ toClient
                Just port -> runTCPClient (ClientSettings port "127.0.0.1") $
                  \fromServer toServer -> do
                    forkIO $ rsrc $$+- toServer
                    fromServer $$ toClient

getVhost =
    peek >>= maybe (return Nothing) (return . go . drop 1 . S8.lines)
  where
    go [] = Nothing
    go (bs:bss)
        | S8.map toLower k == "host" = Just v
        | otherwise = go bss
      where
        (k, v') = S8.break (== ':') bs
        v = S8.takeWhile (not . isSpace) $ S8.dropWhile isSpace $ S8.drop 1 v'