Really terrible HTTP CONNECT proxy for Haskell/WAI

please-no.hs

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}

import Control.Concurrent (forkIO, newEmptyMVar, putMVar, takeMVar)
import Control.Exception (finally)
import Control.Monad
import Control.Monad.Trans (liftIO)
import Data.ByteString.Char8 ()
import qualified Data.ByteString as B
import Data.Monoid
import Network.HTTP.Types

import qualified Network.Wai.Handler.Warp as Warp
import qualified Network.Wai as Wai

import Data.Conduit as C
import qualified Data.Conduit.Network as DCN

proxy :: Wai.Request -> (Wai.Response -> IO Wai.ResponseReceived) -> IO Wai.ResponseReceived
proxy request respond = do
  putStrLn $ "Received: " ++ show request
  case Wai.requestMethod request of
    "CONNECT" -> do
      let hostAndPortInfo = Wai.rawPathInfo request
      -- TODO: parse hostname and port from the above...

      let failure = Wai.responseLBS status500 [] "Upgrade failure"
          upgrade = Wai.responseRaw $ \ input output -> do
            complete <- newEmptyMVar
            let fini = void $ putMVar complete ()

            -- TODO: return 5xx if runTCPClient fails
            void . DCN.runTCPClient (DCN.clientSettings 443 "google.com") $ \ appData -> do
              output "HTTP/1.1 200 Connection Established\r\nProxy-agent: Mega Proxy\r\n\r\n"

              forkIO $ do
                let source =
                      forever $ do
                        input' <- liftIO input
                        when (not $ B.null input') $ yield input'

                finally
                  (runConduit $ source $$ DCN.appSink appData)
                  fini

              forkIO $ do
                let sink = do
                      await >>= \ case
                        Just inp -> liftIO (output inp) >> sink
                        Nothing -> return ()

                finally
                  (runConduit $ DCN.appSource appData $$ sink)
                  fini

              takeMVar complete -- once for the source
              takeMVar complete -- and one for the sink

      respond $ upgrade failure

    _ -> error "blah blah blah"

main :: IO ()
main = do
  Warp.run 3030 proxy
  return ()