http-proxy.hs

{-# LANGUAGE OverloadedStrings #-}
import qualified Network.Wai as Wai
import qualified Network.Wai.Handler.Warp as Warp
import Network.HTTP.Types
import qualified Network.HTTP.Conduit as HC
import qualified Network.HTTP.Client as HCl
import qualified Network.HTTP.Client.Conduit as HCC
import Data.Monoid
import qualified Data.ByteString.Char8 as S8
import Data.Conduit
import Blaze.ByteString.Builder (fromByteString)
import Data.Conduit.Network
import Control.Concurrent.Async (race_)
import qualified Data.Conduit.List as CL
import Network.Wai.Conduit

main :: IO ()
main = do
    man <- HC.newManager HC.conduitManagerSettings
    Warp.runSettings
        ( Warp.setPort 3333
        $ Warp.setNoParsePath True
        $ Warp.defaultSettings
        )
        (proxy man)

proxy :: HC.Manager -> Wai.Application
proxy _ req respond | Wai.requestMethod req == "CONNECT" = respond $ responseRawSource
    (handleConnect req)
    (Wai.responseLBS status500 [("Content-Type", "text/plain")] "No support for responseRaw")
proxy man req respond = do
    print (Wai.rawPathInfo req, Wai.rawQueryString req, Wai.requestHeaders req)
    let url = Wai.rawPathInfo req `mappend` Wai.rawQueryString req
    req2' <- HC.parseUrl $ S8.unpack url
    let req2 = req2'
            { HC.method = Wai.requestMethod req
            , HC.requestHeaders = filter safeReqHeader $ Wai.requestHeaders req
            , HC.requestBody =
                case Wai.requestBodyLength req of
                    Wai.ChunkedBody -> HC.requestBodySourceChunkedIO
                        (sourceRequestBody req)
                    Wai.KnownLength l -> HC.requestBodySourceIO
                        (fromIntegral l)
                        (sourceRequestBody req)
            , HC.decompress = \_ -> True
            , HC.checkStatus = \_ _ _ -> Nothing
            }
    HCl.withResponse req2 man $ \res -> do
        let body = mapOutput (Chunk . fromByteString) $ HCC.bodyReaderSource $ HCl.responseBody res
            headers = filter safeResHeader $ HCl.responseHeaders res
        respond $ responseSource (HCl.responseStatus res) headers body
  where
    safeReqHeader (k, _) = k `elem` -- FIXME expand
        [ "user-agent"
        , "accept"
        , "cookie"
        ]
    safeResHeader (k, _) = k `elem` -- FIXME expand
        [ "content-type"
        ]

handleConnect :: Wai.Request -> Source IO S8.ByteString -> Sink S8.ByteString IO () -> IO ()
handleConnect req fromClient toClient = do
    let (host, port) =
            case S8.break (== ':') $ Wai.rawPathInfo req of
                (x, "") -> (x, 80)
                (x, y) ->
                    case S8.readInt $ S8.drop 1 y of
                        Just (port', "") -> (x, port')
                        Nothing -> (x, 80)
        settings = clientSettings port host
    print ("here1", host, port)
    runTCPClient settings $ \ad -> do
        putStrLn "here2"
        yield "HTTP/1.1 200 OK\r\n\r\n" $$ toClient
        race_
            (fromClient $$ appSink ad)
            (appSource ad $$ toClient)