{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
module Network.Wai.Application.Classic.RevProxy (revProxyApp) where
#if __GLASGOW_HASKELL__ < 709
import Control.Applicative
#endif
import Control.Monad
import Control.Monad.IO.Class (liftIO)
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS (uncons)
import Data.ByteString.Builder (Builder)
import qualified Data.ByteString.Char8 as BS hiding (uncons)
import Data.Conduit
import qualified Network.HTTP.Client as H
import Network.HTTP.Types
import Network.Wai.Application.Classic.Conduit
import Network.Wai.Application.Classic.EventSource
import Network.Wai.Application.Classic.Field
import Network.Wai.Application.Classic.Header
import Network.Wai.Application.Classic.Path
import Network.Wai.Application.Classic.Types
import Network.Wai.Conduit
revProxyApp :: ClassicAppSpec -> RevProxyAppSpec -> RevProxyRoute -> Application
revProxyApp cspec spec route req respond = H.withResponse httpClientRequest mgr proxy
where
proxy hrsp = do
let status = H.responseStatus hrsp
hdr = fixHeader $ H.responseHeaders hrsp
clientBody = H.responseBody hrsp
ct = lookup hContentType hdr
src = toSource ct clientBody
respond $ responseSource status hdr src
httpClientRequest = reqToHReq req route
mgr = revProxyManager spec
fixHeader = addVia cspec req . filter headerToBeRelay
headerToBeRelay :: Header -> Bool
headerToBeRelay (k,_)
| k == hTransferEncoding = False
| k == hAcceptEncoding = False
| k == hContentLength = False
| k == hContentEncoding = False
| otherwise = True
reqToHReq :: Request -> RevProxyRoute -> H.Request
reqToHReq req route = H.defaultRequest {
H.host = revProxyDomain route
, H.port = revProxyPort route
, H.secure = False
, H.requestHeaders = addForwardedFor req $ filter headerToBeRelay hdr
, H.path = path'
, H.queryString = dropQuestion query
, H.requestBody = bodyToHBody len body
, H.method = requestMethod req
, H.proxy = Nothing
, H.decompress = const True
, H.checkResponse = \_ _ -> return ()
, H.redirectCount = 0
}
where
path = rawPathInfo req
src = revProxySrc route
dst = revProxyDst route
hdr = requestHeaders req
query = rawQueryString req
len = requestBodyLength req
body = requestBody req
path' = dst </> (path <\> src)
dropQuestion q = case BS.uncons q of
Just (63, q') -> q'
_ -> q
bodyToHBody :: RequestBodyLength -> IO ByteString -> H.RequestBody
bodyToHBody ChunkedBody src = H.RequestBodyStreamChunked ($ src)
bodyToHBody (KnownLength len) src = H.RequestBodyStream (fromIntegral len) ($ src)
#if MIN_VERSION_conduit(1,3,0)
toSource :: Maybe ByteString -> H.BodyReader -> ConduitT () (Flush Builder) IO ()
#else
toSource :: Maybe ByteString -> H.BodyReader -> Source IO (Flush Builder)
#endif
toSource (Just "text/event-stream") = bodyToEventSource
toSource _ = bodyToSource
#if MIN_VERSION_conduit(1,3,0)
bodyToSource :: H.BodyReader -> ConduitT () (Flush Builder) IO ()
#else
bodyToSource :: H.BodyReader -> Source IO (Flush Builder)
#endif
bodyToSource br = loop
where
loop = do
bs <- liftIO $ H.brRead br
unless (BS.null bs) $ do
yield $ Chunk $ byteStringToBuilder bs
loop