{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE CPP #-}
module Network.HTTP.ReverseProxy
(
ProxyDest (..)
, rawProxyTo
, rawTcpProxyTo
, waiProxyTo
, defaultOnExc
, waiProxyToSettings
, WaiProxyResponse (..)
, WaiProxySettings
, defaultWaiProxySettings
, wpsOnExc
, wpsTimeout
, wpsSetIpHeader
, wpsProcessBody
, wpsUpgradeToRaw
, wpsGetDest
, wpsLogRequest
, SetIpHeader (..)
, LocalWaiProxySettings
, defaultLocalWaiProxySettings
, setLpsTimeBound
) where
import Blaze.ByteString.Builder (Builder, fromByteString,
toLazyByteString)
import Control.Applicative ((<$>), (<|>))
import Control.Monad (unless)
import Data.ByteString (ByteString)
import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy as L
import qualified Data.CaseInsensitive as CI
import Data.Conduit
import qualified Data.Conduit.List as CL
import qualified Data.Conduit.Network as DCN
import Data.Functor.Identity (Identity (..))
import Data.IORef
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as NE
import Data.Maybe (fromMaybe, listToMaybe)
import Data.Monoid (mappend, mconcat, (<>))
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Streaming.Network (AppData, readLens)
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as TLE
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import Data.Word8 (isSpace, _colon, _cr)
import GHC.Generics (Generic)
import Network.HTTP.Client (BodyReader, brRead)
import qualified Network.HTTP.Client as HC
import qualified Network.HTTP.Types as HT
import qualified Network.Wai as WAI
import Network.Wai.Logger (showSockAddr)
import UnliftIO (MonadIO, liftIO, MonadUnliftIO, timeout, SomeException, try, bracket, concurrently_)
data ProxyDest = ProxyDest
{ ProxyDest -> ByteString
pdHost :: !ByteString
, ProxyDest -> Int
pdPort :: !Int
} deriving (ReadPrec [ProxyDest]
ReadPrec ProxyDest
Int -> ReadS ProxyDest
ReadS [ProxyDest]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [ProxyDest]
$creadListPrec :: ReadPrec [ProxyDest]
readPrec :: ReadPrec ProxyDest
$creadPrec :: ReadPrec ProxyDest
readList :: ReadS [ProxyDest]
$creadList :: ReadS [ProxyDest]
readsPrec :: Int -> ReadS ProxyDest
$creadsPrec :: Int -> ReadS ProxyDest
Read, Int -> ProxyDest -> ShowS
[ProxyDest] -> ShowS
ProxyDest -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ProxyDest] -> ShowS
$cshowList :: [ProxyDest] -> ShowS
show :: ProxyDest -> String
$cshow :: ProxyDest -> String
showsPrec :: Int -> ProxyDest -> ShowS
$cshowsPrec :: Int -> ProxyDest -> ShowS
Show, ProxyDest -> ProxyDest -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ProxyDest -> ProxyDest -> Bool
$c/= :: ProxyDest -> ProxyDest -> Bool
== :: ProxyDest -> ProxyDest -> Bool
$c== :: ProxyDest -> ProxyDest -> Bool
Eq, Eq ProxyDest
ProxyDest -> ProxyDest -> Bool
ProxyDest -> ProxyDest -> Ordering
ProxyDest -> ProxyDest -> ProxyDest
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ProxyDest -> ProxyDest -> ProxyDest
$cmin :: ProxyDest -> ProxyDest -> ProxyDest
max :: ProxyDest -> ProxyDest -> ProxyDest
$cmax :: ProxyDest -> ProxyDest -> ProxyDest
>= :: ProxyDest -> ProxyDest -> Bool
$c>= :: ProxyDest -> ProxyDest -> Bool
> :: ProxyDest -> ProxyDest -> Bool
$c> :: ProxyDest -> ProxyDest -> Bool
<= :: ProxyDest -> ProxyDest -> Bool
$c<= :: ProxyDest -> ProxyDest -> Bool
< :: ProxyDest -> ProxyDest -> Bool
$c< :: ProxyDest -> ProxyDest -> Bool
compare :: ProxyDest -> ProxyDest -> Ordering
$ccompare :: ProxyDest -> ProxyDest -> Ordering
Ord, forall x. Rep ProxyDest x -> ProxyDest
forall x. ProxyDest -> Rep ProxyDest x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ProxyDest x -> ProxyDest
$cfrom :: forall x. ProxyDest -> Rep ProxyDest x
Generic)
rawProxyTo :: MonadUnliftIO m
=> (HT.RequestHeaders -> m (Either (DCN.AppData -> m ()) ProxyDest))
-> AppData -> m ()
rawProxyTo :: forall (m :: * -> *).
MonadUnliftIO m =>
(RequestHeaders -> m (Either (AppData -> m ()) ProxyDest))
-> AppData -> m ()
rawProxyTo RequestHeaders -> m (Either (AppData -> m ()) ProxyDest)
getDest AppData
appdata = do
(SealedConduitT () ByteString IO ()
rsrc, RequestHeaders
headers) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall {i}. ConduitT i ByteString IO ()
fromClient forall (m :: * -> *) a b.
Monad m =>
ConduitT () a m ()
-> ConduitT a Void m b -> m (SealedConduitT () a m (), b)
$$+ forall (m :: * -> *) o.
Monad m =>
ConduitT ByteString o m RequestHeaders
getHeaders
Either (AppData -> m ()) ProxyDest
edest <- RequestHeaders -> m (Either (AppData -> m ()) ProxyDest)
getDest RequestHeaders
headers
case Either (AppData -> m ()) ProxyDest
edest of
Left AppData -> m ()
app -> do
IORef (SealedConduitT () ByteString IO ())
irsrc <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (IORef a)
newIORef SealedConduitT () ByteString IO ()
rsrc
let readData :: IO ByteString
readData = do
SealedConduitT () ByteString IO ()
rsrc1 <- forall a. IORef a -> IO a
readIORef IORef (SealedConduitT () ByteString IO ())
irsrc
(SealedConduitT () ByteString IO ()
rsrc2, Maybe ByteString
mbs) <- SealedConduitT () ByteString IO ()
rsrc1 forall (m :: * -> *) a b.
Monad m =>
SealedConduitT () a m ()
-> ConduitT a Void m b -> m (SealedConduitT () a m (), b)
$$++ forall (m :: * -> *) i o. Monad m => ConduitT i o m (Maybe i)
await
forall a. IORef a -> a -> IO ()
writeIORef IORef (SealedConduitT () ByteString IO ())
irsrc SealedConduitT () ByteString IO ()
rsrc2
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe ByteString
"" Maybe ByteString
mbs
AppData -> m ()
app forall a b. (a -> b) -> a -> b
$ forall a. Identity a -> a
runIdentity (forall a (f :: * -> *).
(HasReadWrite a, Functor f) =>
(IO ByteString -> f (IO ByteString)) -> a -> f a
readLens (forall a b. a -> b -> a
const (forall a. a -> Identity a
Identity IO ByteString
readData)) AppData
appdata)
Right (ProxyDest ByteString
host Int
port) -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. ClientSettings -> (AppData -> IO a) -> IO a
DCN.runTCPClient (Int -> ByteString -> ClientSettings
DCN.clientSettings Int
port ByteString
host) (forall {p}.
HasReadWrite p =>
SealedConduitT () ByteString IO () -> p -> IO ()
withServer SealedConduitT () ByteString IO ()
rsrc)
where
fromClient :: ConduitT i ByteString IO ()
fromClient = forall ad (m :: * -> *) i.
(HasReadWrite ad, MonadIO m) =>
ad -> ConduitT i ByteString m ()
DCN.appSource AppData
appdata
toClient :: ConduitT ByteString o IO ()
toClient = forall ad (m :: * -> *) o.
(HasReadWrite ad, MonadIO m) =>
ad -> ConduitT ByteString o m ()
DCN.appSink AppData
appdata
withServer :: SealedConduitT () ByteString IO () -> p -> IO ()
withServer SealedConduitT () ByteString IO ()
rsrc p
appdataServer = forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m ()
concurrently_
(SealedConduitT () ByteString IO ()
rsrc forall (m :: * -> *) a b.
Monad m =>
SealedConduitT () a m () -> ConduitT a Void m b -> m b
$$+- forall {o}. ConduitT ByteString o IO ()
toServer)
(forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit forall a b. (a -> b) -> a -> b
$ forall {i}. ConduitT i ByteString IO ()
fromServer forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall {o}. ConduitT ByteString o IO ()
toClient)
where
fromServer :: ConduitT i ByteString IO ()
fromServer = forall ad (m :: * -> *) i.
(HasReadWrite ad, MonadIO m) =>
ad -> ConduitT i ByteString m ()
DCN.appSource p
appdataServer
toServer :: ConduitT ByteString o IO ()
toServer = forall ad (m :: * -> *) o.
(HasReadWrite ad, MonadIO m) =>
ad -> ConduitT ByteString o m ()
DCN.appSink p
appdataServer
rawTcpProxyTo :: MonadIO m
=> ProxyDest
-> AppData
-> m ()
rawTcpProxyTo :: forall (m :: * -> *). MonadIO m => ProxyDest -> AppData -> m ()
rawTcpProxyTo (ProxyDest ByteString
host Int
port) AppData
appdata = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
forall a. ClientSettings -> (AppData -> IO a) -> IO a
DCN.runTCPClient (Int -> ByteString -> ClientSettings
DCN.clientSettings Int
port ByteString
host) forall {m :: * -> *} {ad}.
(MonadUnliftIO m, HasReadWrite ad) =>
ad -> m ()
withServer
where
withServer :: ad -> m ()
withServer ad
appdataServer = forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m ()
concurrently_
(forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit forall a b. (a -> b) -> a -> b
$ forall ad (m :: * -> *) i.
(HasReadWrite ad, MonadIO m) =>
ad -> ConduitT i ByteString m ()
DCN.appSource AppData
appdata forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall ad (m :: * -> *) o.
(HasReadWrite ad, MonadIO m) =>
ad -> ConduitT ByteString o m ()
DCN.appSink ad
appdataServer)
(forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit forall a b. (a -> b) -> a -> b
$ forall ad (m :: * -> *) i.
(HasReadWrite ad, MonadIO m) =>
ad -> ConduitT i ByteString m ()
DCN.appSource ad
appdataServer forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall ad (m :: * -> *) o.
(HasReadWrite ad, MonadIO m) =>
ad -> ConduitT ByteString o m ()
DCN.appSink AppData
appdata )
defaultOnExc :: SomeException -> WAI.Application
defaultOnExc :: SomeException -> Application
defaultOnExc SomeException
exc Request
_ Response -> IO ResponseReceived
sendResponse = Response -> IO ResponseReceived
sendResponse forall a b. (a -> b) -> a -> b
$ Status -> RequestHeaders -> ByteString -> Response
WAI.responseLBS
Status
HT.status502
[(HeaderName
"content-type", ByteString
"text/plain")]
(ByteString
"Error connecting to gateway:\n\n" forall a. Semigroup a => a -> a -> a
<> Text -> ByteString
TLE.encodeUtf8 (String -> Text
TL.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show SomeException
exc))
data WaiProxyResponse = WPRResponse WAI.Response
| WPRProxyDest ProxyDest
| WPRProxyDestSecure ProxyDest
| WPRModifiedRequest WAI.Request ProxyDest
| WPRModifiedRequestSecure WAI.Request ProxyDest
| WPRApplication WAI.Application
waiProxyTo :: (WAI.Request -> IO WaiProxyResponse)
-> (SomeException -> WAI.Application)
-> HC.Manager
-> WAI.Application
waiProxyTo :: (Request -> IO WaiProxyResponse)
-> (SomeException -> Application) -> Manager -> Application
waiProxyTo Request -> IO WaiProxyResponse
getDest SomeException -> Application
onError = (Request -> IO WaiProxyResponse)
-> WaiProxySettings -> Manager -> Application
waiProxyToSettings Request -> IO WaiProxyResponse
getDest WaiProxySettings
defaultWaiProxySettings { wpsOnExc :: SomeException -> Application
wpsOnExc = SomeException -> Application
onError }
data LocalWaiProxySettings = LocalWaiProxySettings
{ LocalWaiProxySettings -> Maybe Int
lpsTimeBound :: Maybe Int
}
defaultLocalWaiProxySettings :: LocalWaiProxySettings
defaultLocalWaiProxySettings :: LocalWaiProxySettings
defaultLocalWaiProxySettings = Maybe Int -> LocalWaiProxySettings
LocalWaiProxySettings forall a. Maybe a
Nothing
setLpsTimeBound :: Maybe Int -> LocalWaiProxySettings -> LocalWaiProxySettings
setLpsTimeBound :: Maybe Int -> LocalWaiProxySettings -> LocalWaiProxySettings
setLpsTimeBound Maybe Int
x LocalWaiProxySettings
s = LocalWaiProxySettings
s { lpsTimeBound :: Maybe Int
lpsTimeBound = Maybe Int
x }
data WaiProxySettings = WaiProxySettings
{ WaiProxySettings -> SomeException -> Application
wpsOnExc :: SomeException -> WAI.Application
, WaiProxySettings -> Maybe Int
wpsTimeout :: Maybe Int
, :: SetIpHeader
, WaiProxySettings
-> Request
-> Response ()
-> Maybe (ConduitT ByteString (Flush Builder) IO ())
wpsProcessBody :: WAI.Request -> HC.Response () -> Maybe (ConduitT ByteString (Flush Builder) IO ())
, WaiProxySettings -> Request -> Bool
wpsUpgradeToRaw :: WAI.Request -> Bool
, WaiProxySettings
-> Maybe (Request -> IO (LocalWaiProxySettings, WaiProxyResponse))
wpsGetDest :: Maybe (WAI.Request -> IO (LocalWaiProxySettings, WaiProxyResponse))
, WaiProxySettings -> Request -> IO ()
wpsLogRequest :: HC.Request -> IO ()
}
data = SIHNone
| SIHFromSocket
|
defaultWaiProxySettings :: WaiProxySettings
defaultWaiProxySettings :: WaiProxySettings
defaultWaiProxySettings = WaiProxySettings
{ wpsOnExc :: SomeException -> Application
wpsOnExc = SomeException -> Application
defaultOnExc
, wpsTimeout :: Maybe Int
wpsTimeout = forall a. Maybe a
Nothing
, wpsSetIpHeader :: SetIpHeader
wpsSetIpHeader = SetIpHeader
SIHFromSocket
, wpsProcessBody :: Request
-> Response () -> Maybe (ConduitT ByteString (Flush Builder) IO ())
wpsProcessBody = \Request
_ Response ()
_ -> forall a. Maybe a
Nothing
, wpsUpgradeToRaw :: Request -> Bool
wpsUpgradeToRaw = \Request
req ->
(forall s. FoldCase s => s -> CI s
CI.mk forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
"upgrade" (Request -> RequestHeaders
WAI.requestHeaders Request
req)) forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just HeaderName
"websocket"
, wpsGetDest :: Maybe (Request -> IO (LocalWaiProxySettings, WaiProxyResponse))
wpsGetDest = forall a. Maybe a
Nothing
, wpsLogRequest :: Request -> IO ()
wpsLogRequest = forall a b. a -> b -> a
const (forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
}
renderHeaders :: WAI.Request -> HT.RequestHeaders -> Builder
Request
req RequestHeaders
headers
= ByteString -> Builder
fromByteString (Request -> ByteString
WAI.requestMethod Request
req)
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
fromByteString ByteString
" "
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
fromByteString (Request -> ByteString
WAI.rawPathInfo Request
req)
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
fromByteString (Request -> ByteString
WAI.rawQueryString Request
req)
forall a. Semigroup a => a -> a -> a
<> (if Request -> HttpVersion
WAI.httpVersion Request
req forall a. Eq a => a -> a -> Bool
== HttpVersion
HT.http11
then ByteString -> Builder
fromByteString ByteString
" HTTP/1.1"
else ByteString -> Builder
fromByteString ByteString
" HTTP/1.0")
forall a. Semigroup a => a -> a -> a
<> forall a. Monoid a => [a] -> a
mconcat (forall a b. (a -> b) -> [a] -> [b]
map (HeaderName, ByteString) -> Builder
goHeader RequestHeaders
headers)
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
fromByteString ByteString
"\r\n\r\n"
where
goHeader :: (HeaderName, ByteString) -> Builder
goHeader (HeaderName
x, ByteString
y)
= ByteString -> Builder
fromByteString ByteString
"\r\n"
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
fromByteString (forall s. CI s -> s
CI.original HeaderName
x)
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
fromByteString ByteString
": "
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
fromByteString ByteString
y
tryWebSockets :: WaiProxySettings -> ByteString -> Int -> WAI.Request -> (WAI.Response -> IO b) -> IO b -> IO b
tryWebSockets :: forall b.
WaiProxySettings
-> ByteString
-> Int
-> Request
-> (Response -> IO b)
-> IO b
-> IO b
tryWebSockets WaiProxySettings
wps ByteString
host Int
port Request
req Response -> IO b
sendResponse IO b
fallback
| WaiProxySettings -> Request -> Bool
wpsUpgradeToRaw WaiProxySettings
wps Request
req =
Response -> IO b
sendResponse forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip (IO ByteString -> (ByteString -> IO ()) -> IO ())
-> Response -> Response
WAI.responseRaw Response
backup forall a b. (a -> b) -> a -> b
$ \IO ByteString
fromClientBody ByteString -> IO ()
toClient ->
forall a. ClientSettings -> (AppData -> IO a) -> IO a
DCN.runTCPClient ClientSettings
settings forall a b. (a -> b) -> a -> b
$ \AppData
server ->
let toServer :: ConduitT ByteString o IO ()
toServer = forall ad (m :: * -> *) o.
(HasReadWrite ad, MonadIO m) =>
ad -> ConduitT ByteString o m ()
DCN.appSink AppData
server
fromServer :: ConduitT i ByteString IO ()
fromServer = forall ad (m :: * -> *) i.
(HasReadWrite ad, MonadIO m) =>
ad -> ConduitT i ByteString m ()
DCN.appSource AppData
server
fromClient :: ConduitT i ByteString IO ()
fromClient = do
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield forall a b. (a -> b) -> a -> b
$ ByteString -> [ByteString]
L.toChunks forall a b. (a -> b) -> a -> b
$ Builder -> ByteString
toLazyByteString Builder
headers
let loop :: ConduitT i ByteString IO ()
loop = do
ByteString
bs <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ByteString
fromClientBody
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Bool
S.null ByteString
bs) forall a b. (a -> b) -> a -> b
$ do
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield ByteString
bs
ConduitT i ByteString IO ()
loop
forall {i}. ConduitT i ByteString IO ()
loop
toClient' :: ConduitT ByteString o IO ()
toClient' = forall (m :: * -> *) i o r.
Monad m =>
(i -> ConduitT i o m r) -> ConduitT i o m ()
awaitForever forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> IO ()
toClient
headers :: Builder
headers = Request -> RequestHeaders -> Builder
renderHeaders Request
req forall a b. (a -> b) -> a -> b
$ WaiProxySettings -> Request -> RequestHeaders
fixReqHeaders WaiProxySettings
wps Request
req
in forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m ()
concurrently_
(forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit forall a b. (a -> b) -> a -> b
$ forall {i}. ConduitT i ByteString IO ()
fromClient forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall {o}. ConduitT ByteString o IO ()
toServer)
(forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit forall a b. (a -> b) -> a -> b
$ forall {i}. ConduitT i ByteString IO ()
fromServer forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall {o}. ConduitT ByteString o IO ()
toClient')
| Bool
otherwise = IO b
fallback
where
backup :: Response
backup = Status -> RequestHeaders -> ByteString -> Response
WAI.responseLBS Status
HT.status500 [(HeaderName
"Content-Type", ByteString
"text/plain")]
ByteString
"http-reverse-proxy detected WebSockets request, but server does not support responseRaw"
settings :: ClientSettings
settings = Int -> ByteString -> ClientSettings
DCN.clientSettings Int
port ByteString
host
strippedHeaders :: Set HT.HeaderName
= forall a. Ord a => [a] -> Set a
Set.fromList
[HeaderName
"content-length", HeaderName
"transfer-encoding", HeaderName
"accept-encoding", HeaderName
"content-encoding"]
fixReqHeaders :: WaiProxySettings -> WAI.Request -> HT.RequestHeaders
WaiProxySettings
wps Request
req =
RequestHeaders -> RequestHeaders
addXRealIP forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (\(HeaderName
key, ByteString
value) -> Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ HeaderName
key forall a. Ord a => a -> Set a -> Bool
`Set.member` Set HeaderName
strippedHeaders
Bool -> Bool -> Bool
|| (HeaderName
key forall a. Eq a => a -> a -> Bool
== HeaderName
"connection" Bool -> Bool -> Bool
&& ByteString
value forall a. Eq a => a -> a -> Bool
== ByteString
"close"))
forall a b. (a -> b) -> a -> b
$ Request -> RequestHeaders
WAI.requestHeaders Request
req
where
fromSocket :: RequestHeaders -> RequestHeaders
fromSocket = ((HeaderName
"X-Real-IP", String -> ByteString
S8.pack forall a b. (a -> b) -> a -> b
$ SockAddr -> String
showSockAddr forall a b. (a -> b) -> a -> b
$ Request -> SockAddr
WAI.remoteHost Request
req)forall a. a -> [a] -> [a]
:)
fromForwardedFor :: Maybe ByteString
fromForwardedFor = do
ByteString
h <- forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
"x-forwarded-for" (Request -> RequestHeaders
WAI.requestHeaders Request
req)
forall a. [a] -> Maybe a
listToMaybe forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Text -> ByteString
TE.encodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.strip) forall a b. (a -> b) -> a -> b
$ Text -> Text -> [Text]
T.splitOn Text
"," forall a b. (a -> b) -> a -> b
$ ByteString -> Text
TE.decodeUtf8 ByteString
h
addXRealIP :: RequestHeaders -> RequestHeaders
addXRealIP =
case WaiProxySettings -> SetIpHeader
wpsSetIpHeader WaiProxySettings
wps of
SetIpHeader
SIHFromSocket -> RequestHeaders -> RequestHeaders
fromSocket
SetIpHeader
SIHFromHeader ->
case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
"x-real-ip" (Request -> RequestHeaders
WAI.requestHeaders Request
req) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe ByteString
fromForwardedFor of
Maybe ByteString
Nothing -> RequestHeaders -> RequestHeaders
fromSocket
Just ByteString
ip -> ((HeaderName
"X-Real-IP", ByteString
ip)forall a. a -> [a] -> [a]
:)
SetIpHeader
SIHNone -> forall a. a -> a
id
waiProxyToSettings :: (WAI.Request -> IO WaiProxyResponse)
-> WaiProxySettings
-> HC.Manager
-> WAI.Application
waiProxyToSettings :: (Request -> IO WaiProxyResponse)
-> WaiProxySettings -> Manager -> Application
waiProxyToSettings Request -> IO WaiProxyResponse
getDest WaiProxySettings
wps' Manager
manager Request
req0 Response -> IO ResponseReceived
sendResponse = do
let wps :: WaiProxySettings
wps = WaiProxySettings
wps'{wpsGetDest :: Maybe (Request -> IO (LocalWaiProxySettings, WaiProxyResponse))
wpsGetDest = WaiProxySettings
-> Maybe (Request -> IO (LocalWaiProxySettings, WaiProxyResponse))
wpsGetDest WaiProxySettings
wps' forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall a. a -> Maybe a
Just (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe Int -> LocalWaiProxySettings
LocalWaiProxySettings forall a b. (a -> b) -> a -> b
$ WaiProxySettings -> Maybe Int
wpsTimeout WaiProxySettings
wps',) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> IO WaiProxyResponse
getDest)}
(LocalWaiProxySettings
lps, WaiProxyResponse
edest') <- forall a. a -> Maybe a -> a
fromMaybe
(forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return (LocalWaiProxySettings
defaultLocalWaiProxySettings, Response -> WaiProxyResponse
WPRResponse forall a b. (a -> b) -> a -> b
$ Status -> RequestHeaders -> ByteString -> Response
WAI.responseLBS Status
HT.status500 [] ByteString
"proxy not setup"))
(WaiProxySettings
-> Maybe (Request -> IO (LocalWaiProxySettings, WaiProxyResponse))
wpsGetDest WaiProxySettings
wps)
Request
req0
let edest :: Either Application (ProxyDest, Request, Bool)
edest =
case WaiProxyResponse
edest' of
WPRResponse Response
res -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ \Request
_req -> (forall a b. (a -> b) -> a -> b
$ Response
res)
WPRProxyDest ProxyDest
pd -> forall a b. b -> Either a b
Right (ProxyDest
pd, Request
req0, Bool
False)
WPRProxyDestSecure ProxyDest
pd -> forall a b. b -> Either a b
Right (ProxyDest
pd, Request
req0, Bool
True)
WPRModifiedRequest Request
req ProxyDest
pd -> forall a b. b -> Either a b
Right (ProxyDest
pd, Request
req, Bool
False)
WPRModifiedRequestSecure Request
req ProxyDest
pd -> forall a b. b -> Either a b
Right (ProxyDest
pd, Request
req, Bool
True)
WPRApplication Application
app -> forall a b. a -> Either a b
Left Application
app
timeBound :: Int -> IO ResponseReceived -> IO ResponseReceived
timeBound Int
us IO ResponseReceived
f =
forall (m :: * -> *) a.
MonadUnliftIO m =>
Int -> m a -> m (Maybe a)
timeout Int
us IO ResponseReceived
f forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just ResponseReceived
res -> forall (m :: * -> *) a. Monad m => a -> m a
return ResponseReceived
res
Maybe ResponseReceived
Nothing -> Response -> IO ResponseReceived
sendResponse forall a b. (a -> b) -> a -> b
$ Status -> RequestHeaders -> ByteString -> Response
WAI.responseLBS Status
HT.status500 [] ByteString
"timeBound"
case Either Application (ProxyDest, Request, Bool)
edest of
Left Application
app -> forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id Int -> IO ResponseReceived -> IO ResponseReceived
timeBound (LocalWaiProxySettings -> Maybe Int
lpsTimeBound LocalWaiProxySettings
lps) forall a b. (a -> b) -> a -> b
$ Application
app Request
req0 Response -> IO ResponseReceived
sendResponse
Right (ProxyDest ByteString
host Int
port, Request
req, Bool
secure) -> forall b.
WaiProxySettings
-> ByteString
-> Int
-> Request
-> (Response -> IO b)
-> IO b
-> IO b
tryWebSockets WaiProxySettings
wps ByteString
host Int
port Request
req Response -> IO ResponseReceived
sendResponse forall a b. (a -> b) -> a -> b
$ do
GivesPopper ()
scb <- IO ByteString -> IO (GivesPopper ())
semiCachedBody (Request -> IO ByteString
WAI.requestBody Request
req)
let body :: RequestBody
body =
case Request -> RequestBodyLength
WAI.requestBodyLength Request
req of
WAI.KnownLength Word64
i -> Int64 -> GivesPopper () -> RequestBody
HC.RequestBodyStream (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
i) GivesPopper ()
scb
RequestBodyLength
WAI.ChunkedBody -> GivesPopper () -> RequestBody
HC.RequestBodyStreamChunked GivesPopper ()
scb
let req' :: Request
req' =
#if MIN_VERSION_http_client(0, 5, 0)
Request
HC.defaultRequest
{ checkResponse :: Request -> Response (IO ByteString) -> IO ()
HC.checkResponse = \Request
_ Response (IO ByteString)
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
, responseTimeout :: ResponseTimeout
HC.responseTimeout = forall b a. b -> (a -> b) -> Maybe a -> b
maybe ResponseTimeout
HC.responseTimeoutNone Int -> ResponseTimeout
HC.responseTimeoutMicro forall a b. (a -> b) -> a -> b
$ LocalWaiProxySettings -> Maybe Int
lpsTimeBound LocalWaiProxySettings
lps
#else
def
{ HC.checkStatus = \_ _ _ -> Nothing
, HC.responseTimeout = lpsTimeBound lps
#endif
, method :: ByteString
HC.method = Request -> ByteString
WAI.requestMethod Request
req
, secure :: Bool
HC.secure = Bool
secure
, host :: ByteString
HC.host = ByteString
host
, port :: Int
HC.port = Int
port
, path :: ByteString
HC.path = Request -> ByteString
WAI.rawPathInfo Request
req
, queryString :: ByteString
HC.queryString = Request -> ByteString
WAI.rawQueryString Request
req
, requestHeaders :: RequestHeaders
HC.requestHeaders = WaiProxySettings -> Request -> RequestHeaders
fixReqHeaders WaiProxySettings
wps Request
req
, requestBody :: RequestBody
HC.requestBody = RequestBody
body
, redirectCount :: Int
HC.redirectCount = Int
0
}
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket
(forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try forall a b. (a -> b) -> a -> b
$ do
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ WaiProxySettings -> Request -> IO ()
wpsLogRequest WaiProxySettings
wps' Request
req'
Request -> Manager -> IO (Response (IO ByteString))
HC.responseOpen Request
req' Manager
manager)
(forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return ()) forall a. Response a -> IO ()
HC.responseClose)
forall a b. (a -> b) -> a -> b
$ \case
Left SomeException
e -> WaiProxySettings -> SomeException -> Application
wpsOnExc WaiProxySettings
wps SomeException
e Request
req Response -> IO ResponseReceived
sendResponse
Right Response (IO ByteString)
res -> do
let conduit :: ConduitT ByteString (Flush Builder) IO ()
conduit = forall a. a -> Maybe a -> a
fromMaybe
(forall (m :: * -> *) i o r.
Monad m =>
(i -> ConduitT i o m r) -> ConduitT i o m ()
awaitForever (\ByteString
bs -> forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield (forall a. a -> Flush a
Chunk forall a b. (a -> b) -> a -> b
$ ByteString -> Builder
fromByteString ByteString
bs) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield forall a. Flush a
Flush))
(WaiProxySettings
-> Request
-> Response ()
-> Maybe (ConduitT ByteString (Flush Builder) IO ())
wpsProcessBody WaiProxySettings
wps Request
req forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const () forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Response (IO ByteString)
res)
src :: ConduitT i ByteString IO ()
src = forall (m :: * -> *) i.
MonadIO m =>
IO ByteString -> ConduitT i ByteString m ()
bodyReaderSource forall a b. (a -> b) -> a -> b
$ forall body. Response body -> body
HC.responseBody Response (IO ByteString)
res
noChunked :: Bool
noChunked = HttpVersion -> Int
HT.httpMajor (Request -> HttpVersion
WAI.httpVersion Request
req) forall a. Ord a => a -> a -> Bool
>= Int
2 Bool -> Bool -> Bool
|| Request -> ByteString
WAI.requestMethod Request
req forall a. Eq a => a -> a -> Bool
== ByteString
HT.methodHead
Response -> IO ResponseReceived
sendResponse forall a b. (a -> b) -> a -> b
$ Status -> RequestHeaders -> StreamingBody -> Response
WAI.responseStream
(forall body. Response body -> Status
HC.responseStatus Response (IO ByteString)
res)
(forall a. (a -> Bool) -> [a] -> [a]
filter (\(HeaderName
key, ByteString
v) -> Bool -> Bool
not (HeaderName
key forall a. Ord a => a -> Set a -> Bool
`Set.member` Set HeaderName
strippedHeaders) Bool -> Bool -> Bool
||
HeaderName
key forall a. Eq a => a -> a -> Bool
== HeaderName
"content-length" Bool -> Bool -> Bool
&& (Bool
noChunked Bool -> Bool -> Bool
|| ByteString
v forall a. Eq a => a -> a -> Bool
== ByteString
"0"))
(forall body. Response body -> RequestHeaders
HC.responseHeaders Response (IO ByteString)
res))
(\Builder -> IO ()
sendChunk IO ()
flush -> forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit forall a b. (a -> b) -> a -> b
$ forall {i}. ConduitT i ByteString IO ()
src forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT ByteString (Flush Builder) IO ()
conduit forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) a o.
Monad m =>
(a -> m ()) -> ConduitT a o m ()
CL.mapM_ (\Flush Builder
mb ->
case Flush Builder
mb of
Flush Builder
Flush -> IO ()
flush
Chunk Builder
b -> Builder -> IO ()
sendChunk Builder
b))
semiCachedBody :: IO ByteString -> IO (HC.GivesPopper ())
semiCachedBody :: IO ByteString -> IO (GivesPopper ())
semiCachedBody IO ByteString
orig = do
IORef SCB
ref <- forall a. a -> IO (IORef a)
newIORef forall a b. (a -> b) -> a -> b
$ Int -> [ByteString] -> SCB
SCBCaching Int
0 []
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ \NeedsPopper ()
needsPopper -> do
let fromChunks :: Int -> [ByteString] -> SCB
fromChunks Int
len [ByteString]
chunks =
case forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty (forall a. [a] -> [a]
reverse [ByteString]
chunks) of
Maybe (NonEmpty ByteString)
Nothing -> Int -> [ByteString] -> SCB
SCBCaching Int
len [ByteString]
chunks
Just NonEmpty ByteString
toDrain -> Int -> [ByteString] -> NonEmpty ByteString -> SCB
SCBDraining Int
len [ByteString]
chunks NonEmpty ByteString
toDrain
SCB
state0 <- forall a. IORef a -> IO a
readIORef IORef SCB
ref forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
\case
SCBCaching Int
len [ByteString]
chunks -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Int -> [ByteString] -> SCB
fromChunks Int
len [ByteString]
chunks
SCBDraining Int
len [ByteString]
chunks NonEmpty ByteString
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Int -> [ByteString] -> SCB
fromChunks Int
len [ByteString]
chunks
SCB
SCBTooMuchData -> forall a. HasCallStack => String -> a
error String
"Cannot retry this request body, need to force a new request"
forall a. IORef a -> a -> IO ()
writeIORef IORef SCB
ref forall a b. (a -> b) -> a -> b
$! SCB
state0
let popper :: IO ByteString
popper :: IO ByteString
popper = do
forall a. IORef a -> IO a
readIORef IORef SCB
ref forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
\case
SCBDraining Int
len [ByteString]
chunks (ByteString
next:|[ByteString]
rest) -> do
forall a. IORef a -> a -> IO ()
writeIORef IORef SCB
ref forall a b. (a -> b) -> a -> b
$!
case [ByteString]
rest of
[] -> Int -> [ByteString] -> SCB
SCBCaching Int
len [ByteString]
chunks
ByteString
x:[ByteString]
xs -> Int -> [ByteString] -> NonEmpty ByteString -> SCB
SCBDraining Int
len [ByteString]
chunks (ByteString
xforall a. a -> [a] -> NonEmpty a
:|[ByteString]
xs)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
next
SCB
SCBTooMuchData -> IO ByteString
orig
SCBCaching Int
len [ByteString]
chunks -> do
ByteString
bs <- IO ByteString
orig
let newLen :: Int
newLen = Int
len forall a. Num a => a -> a -> a
+ ByteString -> Int
S.length ByteString
bs
forall a. IORef a -> a -> IO ()
writeIORef IORef SCB
ref forall a b. (a -> b) -> a -> b
$!
if Int
newLen forall a. Ord a => a -> a -> Bool
> Int
maxCache
then SCB
SCBTooMuchData
else Int -> [ByteString] -> SCB
SCBCaching Int
newLen (ByteString
bsforall a. a -> [a] -> [a]
:[ByteString]
chunks)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
bs
NeedsPopper ()
needsPopper IO ByteString
popper
where
maxCache :: Int
maxCache = Int
65535
data SCB
= SCBCaching !Int ![ByteString]
| SCBDraining !Int ![ByteString] !(NonEmpty ByteString)
| SCBTooMuchData
getHeaders :: Monad m => ConduitT ByteString o m HT.RequestHeaders
=
ByteString -> RequestHeaders
toHeaders forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {m :: * -> *} {o}.
Monad m =>
(ByteString -> ByteString) -> ConduitT ByteString o m ByteString
go forall a. a -> a
id
where
go :: (ByteString -> ByteString) -> ConduitT ByteString o m ByteString
go ByteString -> ByteString
front =
forall (m :: * -> *) i o. Monad m => ConduitT i o m (Maybe i)
await forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall {o} {m :: * -> *}. ConduitT ByteString o m ByteString
close ByteString -> ConduitT ByteString o m ByteString
push
where
close :: ConduitT ByteString o m ByteString
close = forall i o (m :: * -> *). i -> ConduitT i o m ()
leftover ByteString
bs forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
bs
where
bs :: ByteString
bs = ByteString -> ByteString
front ByteString
S8.empty
push :: ByteString -> ConduitT ByteString o m ByteString
push ByteString
bs'
| ByteString
"\r\n\r\n" ByteString -> ByteString -> Bool
`S8.isInfixOf` ByteString
bs
Bool -> Bool -> Bool
|| ByteString
"\n\n" ByteString -> ByteString -> Bool
`S8.isInfixOf` ByteString
bs
Bool -> Bool -> Bool
|| ByteString -> Int
S8.length ByteString
bs forall a. Ord a => a -> a -> Bool
> Int
4096 = forall i o (m :: * -> *). i -> ConduitT i o m ()
leftover ByteString
bs forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
bs
| Bool
otherwise = (ByteString -> ByteString) -> ConduitT ByteString o m ByteString
go forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => a -> a -> a
mappend ByteString
bs
where
bs :: ByteString
bs = ByteString -> ByteString
front ByteString
bs'
toHeaders :: ByteString -> RequestHeaders
toHeaders = forall a b. (a -> b) -> [a] -> [b]
map ByteString -> (HeaderName, ByteString)
toHeader forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Bool
S8.null) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> [a] -> [a]
drop Int
1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
S8.lines
toHeader :: ByteString -> (HeaderName, ByteString)
toHeader ByteString
bs =
(forall s. FoldCase s => s -> CI s
CI.mk ByteString
key, ByteString
val)
where
(ByteString
key, ByteString
bs') = (Word8 -> Bool) -> ByteString -> (ByteString, ByteString)
S.break (forall a. Eq a => a -> a -> Bool
== Word8
_colon) ByteString
bs
val :: ByteString
val = (Word8 -> Bool) -> ByteString -> ByteString
S.takeWhile (forall a. Eq a => a -> a -> Bool
/= Word8
_cr) forall a b. (a -> b) -> a -> b
$ (Word8 -> Bool) -> ByteString -> ByteString
S.dropWhile Word8 -> Bool
isSpace forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
S.drop Int
1 ByteString
bs'
bodyReaderSource :: MonadIO m => BodyReader -> ConduitT i ByteString m ()
bodyReaderSource :: forall (m :: * -> *) i.
MonadIO m =>
IO ByteString -> ConduitT i ByteString m ()
bodyReaderSource IO ByteString
br =
forall {i}. ConduitT i ByteString m ()
loop
where
loop :: ConduitT i ByteString m ()
loop = do
ByteString
bs <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ IO ByteString -> IO ByteString
brRead IO ByteString
br
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Bool
S.null ByteString
bs) forall a b. (a -> b) -> a -> b
$ do
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield ByteString
bs
ConduitT i ByteString m ()
loop