{-# 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
, 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.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]
(Int -> ReadS ProxyDest)
-> ReadS [ProxyDest]
-> ReadPrec ProxyDest
-> ReadPrec [ProxyDest]
-> Read 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
(Int -> ProxyDest -> ShowS)
-> (ProxyDest -> String)
-> ([ProxyDest] -> ShowS)
-> Show ProxyDest
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
(ProxyDest -> ProxyDest -> Bool)
-> (ProxyDest -> ProxyDest -> Bool) -> Eq ProxyDest
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
Eq ProxyDest =>
(ProxyDest -> ProxyDest -> Ordering)
-> (ProxyDest -> ProxyDest -> Bool)
-> (ProxyDest -> ProxyDest -> Bool)
-> (ProxyDest -> ProxyDest -> Bool)
-> (ProxyDest -> ProxyDest -> Bool)
-> (ProxyDest -> ProxyDest -> ProxyDest)
-> (ProxyDest -> ProxyDest -> ProxyDest)
-> Ord 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
$cp1Ord :: Eq ProxyDest
Ord, (forall x. ProxyDest -> Rep ProxyDest x)
-> (forall x. Rep ProxyDest x -> ProxyDest) -> Generic ProxyDest
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 :: (RequestHeaders -> m (Either (AppData -> m ()) ProxyDest))
-> AppData -> m ()
rawProxyTo getDest :: RequestHeaders -> m (Either (AppData -> m ()) ProxyDest)
getDest appdata :: AppData
appdata = do
(rsrc :: SealedConduitT () ByteString IO ()
rsrc, headers :: RequestHeaders
headers) <- IO (SealedConduitT () ByteString IO (), RequestHeaders)
-> m (SealedConduitT () ByteString IO (), RequestHeaders)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (SealedConduitT () ByteString IO (), RequestHeaders)
-> m (SealedConduitT () ByteString IO (), RequestHeaders))
-> IO (SealedConduitT () ByteString IO (), RequestHeaders)
-> m (SealedConduitT () ByteString IO (), RequestHeaders)
forall a b. (a -> b) -> a -> b
$ ConduitT () ByteString IO ()
forall i. ConduitT i ByteString IO ()
fromClient ConduitT () ByteString IO ()
-> Sink ByteString IO RequestHeaders
-> IO (SealedConduitT () ByteString IO (), RequestHeaders)
forall (m :: * -> *) a b.
Monad m =>
Source m a -> Sink a m b -> m (SealedConduitT () a m (), b)
$$+ Sink ByteString IO RequestHeaders
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 app :: AppData -> m ()
app -> do
IORef (SealedConduitT () ByteString IO ())
irsrc <- IO (IORef (SealedConduitT () ByteString IO ()))
-> m (IORef (SealedConduitT () ByteString IO ()))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef (SealedConduitT () ByteString IO ()))
-> m (IORef (SealedConduitT () ByteString IO ())))
-> IO (IORef (SealedConduitT () ByteString IO ()))
-> m (IORef (SealedConduitT () ByteString IO ()))
forall a b. (a -> b) -> a -> b
$ SealedConduitT () ByteString IO ()
-> IO (IORef (SealedConduitT () ByteString IO ()))
forall a. a -> IO (IORef a)
newIORef SealedConduitT () ByteString IO ()
rsrc
let readData :: IO ByteString
readData = do
SealedConduitT () ByteString IO ()
rsrc1 <- IORef (SealedConduitT () ByteString IO ())
-> IO (SealedConduitT () ByteString IO ())
forall a. IORef a -> IO a
readIORef IORef (SealedConduitT () ByteString IO ())
irsrc
(rsrc2 :: SealedConduitT () ByteString IO ()
rsrc2, mbs :: Maybe ByteString
mbs) <- SealedConduitT () ByteString IO ()
rsrc1 SealedConduitT () ByteString IO ()
-> Sink ByteString IO (Maybe ByteString)
-> IO (SealedConduitT () ByteString IO (), Maybe ByteString)
forall (m :: * -> *) a b.
Monad m =>
SealedConduitT () a m ()
-> Sink a m b -> m (SealedConduitT () a m (), b)
$$++ Sink ByteString IO (Maybe ByteString)
forall (m :: * -> *) i. Monad m => Consumer i m (Maybe i)
await
IORef (SealedConduitT () ByteString IO ())
-> SealedConduitT () ByteString IO () -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (SealedConduitT () ByteString IO ())
irsrc SealedConduitT () ByteString IO ()
rsrc2
ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe "" Maybe ByteString
mbs
AppData -> m ()
app (AppData -> m ()) -> AppData -> m ()
forall a b. (a -> b) -> a -> b
$ Identity AppData -> AppData
forall a. Identity a -> a
runIdentity ((IO ByteString -> Identity (IO ByteString))
-> AppData -> Identity AppData
forall a (f :: * -> *).
(HasReadWrite a, Functor f) =>
(IO ByteString -> f (IO ByteString)) -> a -> f a
readLens (Identity (IO ByteString)
-> IO ByteString -> Identity (IO ByteString)
forall a b. a -> b -> a
const (IO ByteString -> Identity (IO ByteString)
forall a. a -> Identity a
Identity IO ByteString
readData)) AppData
appdata)
Right (ProxyDest host :: ByteString
host port :: Int
port) -> IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ ClientSettings -> (AppData -> IO ()) -> IO ()
forall a. ClientSettings -> (AppData -> IO a) -> IO a
DCN.runTCPClient (Int -> ByteString -> ClientSettings
DCN.clientSettings Int
port ByteString
host) (SealedConduitT () ByteString IO () -> AppData -> IO ()
forall ad.
HasReadWrite ad =>
SealedConduitT () ByteString IO () -> ad -> IO ()
withServer SealedConduitT () ByteString IO ()
rsrc)
where
fromClient :: ConduitT i ByteString IO ()
fromClient = AppData -> ConduitT i ByteString IO ()
forall ad (m :: * -> *) i.
(HasReadWrite ad, MonadIO m) =>
ad -> ConduitT i ByteString m ()
DCN.appSource AppData
appdata
toClient :: ConduitT ByteString o IO ()
toClient = AppData -> ConduitT ByteString o IO ()
forall ad (m :: * -> *) o.
(HasReadWrite ad, MonadIO m) =>
ad -> ConduitT ByteString o m ()
DCN.appSink AppData
appdata
withServer :: SealedConduitT () ByteString IO () -> ad -> IO ()
withServer rsrc :: SealedConduitT () ByteString IO ()
rsrc appdataServer :: ad
appdataServer = IO () -> IO () -> IO ()
forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m ()
concurrently_
(SealedConduitT () ByteString IO ()
rsrc SealedConduitT () ByteString IO ()
-> Sink ByteString IO () -> IO ()
forall (m :: * -> *) a b.
Monad m =>
SealedConduitT () a m () -> Sink a m b -> m b
$$+- Sink ByteString IO ()
forall o. ConduitT ByteString o IO ()
toServer)
(ConduitT () Void IO () -> IO ()
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit (ConduitT () Void IO () -> IO ())
-> ConduitT () Void IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ ConduitT () ByteString IO ()
forall i. ConduitT i ByteString IO ()
fromServer ConduitT () ByteString IO ()
-> Sink ByteString IO () -> ConduitT () Void IO ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| Sink ByteString IO ()
forall o. ConduitT ByteString o IO ()
toClient)
where
fromServer :: ConduitT i ByteString IO ()
fromServer = ad -> ConduitT i ByteString IO ()
forall ad (m :: * -> *) i.
(HasReadWrite ad, MonadIO m) =>
ad -> ConduitT i ByteString m ()
DCN.appSource ad
appdataServer
toServer :: ConduitT ByteString o IO ()
toServer = ad -> ConduitT ByteString o IO ()
forall ad (m :: * -> *) o.
(HasReadWrite ad, MonadIO m) =>
ad -> ConduitT ByteString o m ()
DCN.appSink ad
appdataServer
rawTcpProxyTo :: MonadIO m
=> ProxyDest
-> AppData
-> m ()
rawTcpProxyTo :: ProxyDest -> AppData -> m ()
rawTcpProxyTo (ProxyDest host :: ByteString
host port :: Int
port) appdata :: AppData
appdata = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
ClientSettings -> (AppData -> IO ()) -> IO ()
forall a. ClientSettings -> (AppData -> IO a) -> IO a
DCN.runTCPClient (Int -> ByteString -> ClientSettings
DCN.clientSettings Int
port ByteString
host) AppData -> IO ()
forall (m :: * -> *) ad.
(MonadUnliftIO m, HasReadWrite ad) =>
ad -> m ()
withServer
where
withServer :: ad -> m ()
withServer appdataServer :: ad
appdataServer = m () -> m () -> m ()
forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m ()
concurrently_
(ConduitT () Void m () -> m ()
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit (ConduitT () Void m () -> m ()) -> ConduitT () Void m () -> m ()
forall a b. (a -> b) -> a -> b
$ AppData -> ConduitT () ByteString m ()
forall ad (m :: * -> *) i.
(HasReadWrite ad, MonadIO m) =>
ad -> ConduitT i ByteString m ()
DCN.appSource AppData
appdata ConduitT () ByteString m ()
-> ConduitM ByteString Void m () -> ConduitT () Void m ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ad -> ConduitM ByteString Void m ()
forall ad (m :: * -> *) o.
(HasReadWrite ad, MonadIO m) =>
ad -> ConduitT ByteString o m ()
DCN.appSink ad
appdataServer)
(ConduitT () Void m () -> m ()
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit (ConduitT () Void m () -> m ()) -> ConduitT () Void m () -> m ()
forall a b. (a -> b) -> a -> b
$ ad -> ConduitT () ByteString m ()
forall ad (m :: * -> *) i.
(HasReadWrite ad, MonadIO m) =>
ad -> ConduitT i ByteString m ()
DCN.appSource ad
appdataServer ConduitT () ByteString m ()
-> ConduitM ByteString Void m () -> ConduitT () Void m ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| AppData -> ConduitM ByteString Void m ()
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 exc :: SomeException
exc _ sendResponse :: Response -> IO ResponseReceived
sendResponse = Response -> IO ResponseReceived
sendResponse (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ Status -> RequestHeaders -> ByteString -> Response
WAI.responseLBS
Status
HT.status502
[("content-type", "text/plain")]
("Error connecting to gateway:\n\n" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Text -> ByteString
TLE.encodeUtf8 (String -> Text
TL.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ SomeException -> String
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 getDest :: Request -> IO WaiProxyResponse
getDest onError :: 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 Maybe Int
forall a. Maybe a
Nothing
setLpsTimeBound :: Maybe Int -> LocalWaiProxySettings -> LocalWaiProxySettings
setLpsTimeBound :: Maybe Int -> LocalWaiProxySettings -> LocalWaiProxySettings
setLpsTimeBound x :: Maybe Int
x s :: 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))
}
data = SIHNone
| SIHFromSocket
|
defaultWaiProxySettings :: WaiProxySettings
defaultWaiProxySettings :: WaiProxySettings
defaultWaiProxySettings = WaiProxySettings :: (SomeException -> Application)
-> Maybe Int
-> SetIpHeader
-> (Request
-> Response ()
-> Maybe (ConduitT ByteString (Flush Builder) IO ()))
-> (Request -> Bool)
-> Maybe (Request -> IO (LocalWaiProxySettings, WaiProxyResponse))
-> WaiProxySettings
WaiProxySettings
{ wpsOnExc :: SomeException -> Application
wpsOnExc = SomeException -> Application
defaultOnExc
, wpsTimeout :: Maybe Int
wpsTimeout = Maybe Int
forall a. Maybe a
Nothing
, wpsSetIpHeader :: SetIpHeader
wpsSetIpHeader = SetIpHeader
SIHFromSocket
, wpsProcessBody :: Request
-> Response () -> Maybe (ConduitT ByteString (Flush Builder) IO ())
wpsProcessBody = \_ _ -> Maybe (ConduitT ByteString (Flush Builder) IO ())
forall a. Maybe a
Nothing
, wpsUpgradeToRaw :: Request -> Bool
wpsUpgradeToRaw = \req :: Request
req ->
(ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
CI.mk (ByteString -> CI ByteString)
-> Maybe ByteString -> Maybe (CI ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CI ByteString -> RequestHeaders -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup "upgrade" (Request -> RequestHeaders
WAI.requestHeaders Request
req)) Maybe (CI ByteString) -> Maybe (CI ByteString) -> Bool
forall a. Eq a => a -> a -> Bool
== CI ByteString -> Maybe (CI ByteString)
forall a. a -> Maybe a
Just "websocket"
, wpsGetDest :: Maybe (Request -> IO (LocalWaiProxySettings, WaiProxyResponse))
wpsGetDest = Maybe (Request -> IO (LocalWaiProxySettings, WaiProxyResponse))
forall a. Maybe a
Nothing
}
renderHeaders :: WAI.Request -> HT.RequestHeaders -> Builder
req :: Request
req headers :: RequestHeaders
headers
= ByteString -> Builder
fromByteString (Request -> ByteString
WAI.requestMethod Request
req)
Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
fromByteString " "
Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
fromByteString (Request -> ByteString
WAI.rawPathInfo Request
req)
Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
fromByteString (Request -> ByteString
WAI.rawQueryString Request
req)
Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> (if Request -> HttpVersion
WAI.httpVersion Request
req HttpVersion -> HttpVersion -> Bool
forall a. Eq a => a -> a -> Bool
== HttpVersion
HT.http11
then ByteString -> Builder
fromByteString " HTTP/1.1"
else ByteString -> Builder
fromByteString " HTTP/1.0")
Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat (((CI ByteString, ByteString) -> Builder)
-> RequestHeaders -> [Builder]
forall a b. (a -> b) -> [a] -> [b]
map (CI ByteString, ByteString) -> Builder
goHeader RequestHeaders
headers)
Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
fromByteString "\r\n\r\n"
where
goHeader :: (CI ByteString, ByteString) -> Builder
goHeader (x :: CI ByteString
x, y :: ByteString
y)
= ByteString -> Builder
fromByteString "\r\n"
Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
fromByteString (CI ByteString -> ByteString
forall s. CI s -> s
CI.original CI ByteString
x)
Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
fromByteString ": "
Builder -> Builder -> Builder
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 :: WaiProxySettings
-> ByteString
-> Int
-> Request
-> (Response -> IO b)
-> IO b
-> IO b
tryWebSockets wps :: WaiProxySettings
wps host :: ByteString
host port :: Int
port req :: Request
req sendResponse :: Response -> IO b
sendResponse fallback :: IO b
fallback
| WaiProxySettings -> Request -> Bool
wpsUpgradeToRaw WaiProxySettings
wps Request
req =
Response -> IO b
sendResponse (Response -> IO b) -> Response -> IO b
forall a b. (a -> b) -> a -> b
$ ((IO ByteString -> (ByteString -> IO ()) -> IO ())
-> Response -> Response)
-> Response
-> (IO ByteString -> (ByteString -> IO ()) -> IO ())
-> Response
forall a b c. (a -> b -> c) -> b -> a -> c
flip (IO ByteString -> (ByteString -> IO ()) -> IO ())
-> Response -> Response
WAI.responseRaw Response
backup ((IO ByteString -> (ByteString -> IO ()) -> IO ()) -> Response)
-> (IO ByteString -> (ByteString -> IO ()) -> IO ()) -> Response
forall a b. (a -> b) -> a -> b
$ \fromClientBody :: IO ByteString
fromClientBody toClient :: ByteString -> IO ()
toClient ->
ClientSettings -> (AppData -> IO ()) -> IO ()
forall a. ClientSettings -> (AppData -> IO a) -> IO a
DCN.runTCPClient ClientSettings
settings ((AppData -> IO ()) -> IO ()) -> (AppData -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \server :: AppData
server ->
let toServer :: ConduitT ByteString o IO ()
toServer = AppData -> ConduitT ByteString o IO ()
forall ad (m :: * -> *) o.
(HasReadWrite ad, MonadIO m) =>
ad -> ConduitT ByteString o m ()
DCN.appSink AppData
server
fromServer :: ConduitT i ByteString IO ()
fromServer = AppData -> ConduitT i ByteString IO ()
forall ad (m :: * -> *) i.
(HasReadWrite ad, MonadIO m) =>
ad -> ConduitT i ByteString m ()
DCN.appSource AppData
server
fromClient :: ConduitT i ByteString IO ()
fromClient = do
(ByteString -> ConduitT i ByteString IO ())
-> [ByteString] -> ConduitT i ByteString IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ByteString -> ConduitT i ByteString IO ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield ([ByteString] -> ConduitT i ByteString IO ())
-> [ByteString] -> ConduitT i ByteString IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> [ByteString]
L.toChunks (ByteString -> [ByteString]) -> ByteString -> [ByteString]
forall a b. (a -> b) -> a -> b
$ Builder -> ByteString
toLazyByteString Builder
headers
let loop :: ConduitT i ByteString IO ()
loop = do
ByteString
bs <- IO ByteString -> ConduitT i ByteString IO ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ByteString
fromClientBody
Bool -> ConduitT i ByteString IO () -> ConduitT i ByteString IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Bool
S.null ByteString
bs) (ConduitT i ByteString IO () -> ConduitT i ByteString IO ())
-> ConduitT i ByteString IO () -> ConduitT i ByteString IO ()
forall a b. (a -> b) -> a -> b
$ do
ByteString -> ConduitT i ByteString IO ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield ByteString
bs
ConduitT i ByteString IO ()
loop
ConduitT i ByteString IO ()
forall i. ConduitT i ByteString IO ()
loop
toClient' :: ConduitT ByteString o IO ()
toClient' = (ByteString -> ConduitT ByteString o IO ())
-> ConduitT ByteString o IO ()
forall (m :: * -> *) i o r.
Monad m =>
(i -> ConduitT i o m r) -> ConduitT i o m ()
awaitForever ((ByteString -> ConduitT ByteString o IO ())
-> ConduitT ByteString o IO ())
-> (ByteString -> ConduitT ByteString o IO ())
-> ConduitT ByteString o IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> ConduitT ByteString o IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ConduitT ByteString o IO ())
-> (ByteString -> IO ())
-> ByteString
-> ConduitT ByteString o IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> IO ()
toClient
headers :: Builder
headers = Request -> RequestHeaders -> Builder
renderHeaders Request
req (RequestHeaders -> Builder) -> RequestHeaders -> Builder
forall a b. (a -> b) -> a -> b
$ WaiProxySettings -> Request -> RequestHeaders
fixReqHeaders WaiProxySettings
wps Request
req
in IO () -> IO () -> IO ()
forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m ()
concurrently_
(ConduitT () Void IO () -> IO ()
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit (ConduitT () Void IO () -> IO ())
-> ConduitT () Void IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ ConduitT () ByteString IO ()
forall i. ConduitT i ByteString IO ()
fromClient ConduitT () ByteString IO ()
-> Sink ByteString IO () -> ConduitT () Void IO ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| Sink ByteString IO ()
forall o. ConduitT ByteString o IO ()
toServer)
(ConduitT () Void IO () -> IO ()
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit (ConduitT () Void IO () -> IO ())
-> ConduitT () Void IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ ConduitT () ByteString IO ()
forall i. ConduitT i ByteString IO ()
fromServer ConduitT () ByteString IO ()
-> Sink ByteString IO () -> ConduitT () Void IO ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| Sink ByteString IO ()
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 [("Content-Type", "text/plain")]
"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
= [CI ByteString] -> Set (CI ByteString)
forall a. Ord a => [a] -> Set a
Set.fromList
["content-length", "transfer-encoding", "accept-encoding", "content-encoding"]
fixReqHeaders :: WaiProxySettings -> WAI.Request -> HT.RequestHeaders
wps :: WaiProxySettings
wps req :: Request
req =
RequestHeaders -> RequestHeaders
addXRealIP (RequestHeaders -> RequestHeaders)
-> RequestHeaders -> RequestHeaders
forall a b. (a -> b) -> a -> b
$ ((CI ByteString, ByteString) -> Bool)
-> RequestHeaders -> RequestHeaders
forall a. (a -> Bool) -> [a] -> [a]
filter (\(key :: CI ByteString
key, value :: ByteString
value) -> Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ CI ByteString
key CI ByteString -> Set (CI ByteString) -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set (CI ByteString)
strippedHeaders
Bool -> Bool -> Bool
|| (CI ByteString
key CI ByteString -> CI ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== "connection" Bool -> Bool -> Bool
&& ByteString
value ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== "close"))
(RequestHeaders -> RequestHeaders)
-> RequestHeaders -> RequestHeaders
forall a b. (a -> b) -> a -> b
$ Request -> RequestHeaders
WAI.requestHeaders Request
req
where
fromSocket :: RequestHeaders -> RequestHeaders
fromSocket = (("X-Real-IP", String -> ByteString
S8.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ SockAddr -> String
showSockAddr (SockAddr -> String) -> SockAddr -> String
forall a b. (a -> b) -> a -> b
$ Request -> SockAddr
WAI.remoteHost Request
req)(CI ByteString, ByteString) -> RequestHeaders -> RequestHeaders
forall a. a -> [a] -> [a]
:)
fromForwardedFor :: Maybe ByteString
fromForwardedFor = do
ByteString
h <- CI ByteString -> RequestHeaders -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup "x-forwarded-for" (Request -> RequestHeaders
WAI.requestHeaders Request
req)
[ByteString] -> Maybe ByteString
forall a. [a] -> Maybe a
listToMaybe ([ByteString] -> Maybe ByteString)
-> [ByteString] -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ (Text -> ByteString) -> [Text] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> ByteString
TE.encodeUtf8 (Text -> ByteString) -> (Text -> Text) -> Text -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.strip) ([Text] -> [ByteString]) -> [Text] -> [ByteString]
forall a b. (a -> b) -> a -> b
$ Text -> Text -> [Text]
T.splitOn "," (Text -> [Text]) -> Text -> [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
SIHFromSocket -> RequestHeaders -> RequestHeaders
fromSocket
SIHFromHeader ->
case CI ByteString -> RequestHeaders -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup "x-real-ip" (Request -> RequestHeaders
WAI.requestHeaders Request
req) Maybe ByteString -> Maybe ByteString -> Maybe ByteString
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe ByteString
fromForwardedFor of
Nothing -> RequestHeaders -> RequestHeaders
fromSocket
Just ip :: ByteString
ip -> (("X-Real-IP", ByteString
ip)(CI ByteString, ByteString) -> RequestHeaders -> RequestHeaders
forall a. a -> [a] -> [a]
:)
SIHNone -> RequestHeaders -> RequestHeaders
forall a. a -> a
id
waiProxyToSettings :: (WAI.Request -> IO WaiProxyResponse)
-> WaiProxySettings
-> HC.Manager
-> WAI.Application
waiProxyToSettings :: (Request -> IO WaiProxyResponse)
-> WaiProxySettings -> Manager -> Application
waiProxyToSettings getDest :: Request -> IO WaiProxyResponse
getDest wps' :: WaiProxySettings
wps' manager :: Manager
manager req0 :: Request
req0 sendResponse :: 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' Maybe (Request -> IO (LocalWaiProxySettings, WaiProxyResponse))
-> Maybe (Request -> IO (LocalWaiProxySettings, WaiProxyResponse))
-> Maybe (Request -> IO (LocalWaiProxySettings, WaiProxyResponse))
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Request -> IO (LocalWaiProxySettings, WaiProxyResponse))
-> Maybe (Request -> IO (LocalWaiProxySettings, WaiProxyResponse))
forall a. a -> Maybe a
Just ((WaiProxyResponse -> (LocalWaiProxySettings, WaiProxyResponse))
-> IO WaiProxyResponse
-> IO (LocalWaiProxySettings, WaiProxyResponse)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe Int -> LocalWaiProxySettings
LocalWaiProxySettings (Maybe Int -> LocalWaiProxySettings)
-> Maybe Int -> LocalWaiProxySettings
forall a b. (a -> b) -> a -> b
$ WaiProxySettings -> Maybe Int
wpsTimeout WaiProxySettings
wps',) (IO WaiProxyResponse
-> IO (LocalWaiProxySettings, WaiProxyResponse))
-> (Request -> IO WaiProxyResponse)
-> Request
-> IO (LocalWaiProxySettings, WaiProxyResponse)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> IO WaiProxyResponse
getDest)}
(lps :: LocalWaiProxySettings
lps, edest' :: WaiProxyResponse
edest') <- (Request -> IO (LocalWaiProxySettings, WaiProxyResponse))
-> Maybe (Request -> IO (LocalWaiProxySettings, WaiProxyResponse))
-> Request
-> IO (LocalWaiProxySettings, WaiProxyResponse)
forall a. a -> Maybe a -> a
fromMaybe
(IO (LocalWaiProxySettings, WaiProxyResponse)
-> Request -> IO (LocalWaiProxySettings, WaiProxyResponse)
forall a b. a -> b -> a
const (IO (LocalWaiProxySettings, WaiProxyResponse)
-> Request -> IO (LocalWaiProxySettings, WaiProxyResponse))
-> IO (LocalWaiProxySettings, WaiProxyResponse)
-> Request
-> IO (LocalWaiProxySettings, WaiProxyResponse)
forall a b. (a -> b) -> a -> b
$ (LocalWaiProxySettings, WaiProxyResponse)
-> IO (LocalWaiProxySettings, WaiProxyResponse)
forall (m :: * -> *) a. Monad m => a -> m a
return (LocalWaiProxySettings
defaultLocalWaiProxySettings, Response -> WaiProxyResponse
WPRResponse (Response -> WaiProxyResponse) -> Response -> WaiProxyResponse
forall a b. (a -> b) -> a -> b
$ Status -> RequestHeaders -> ByteString -> Response
WAI.responseLBS Status
HT.status500 [] "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 res :: Response
res -> Application -> Either Application (ProxyDest, Request, Bool)
forall a b. a -> Either a b
Left (Application -> Either Application (ProxyDest, Request, Bool))
-> Application -> Either Application (ProxyDest, Request, Bool)
forall a b. (a -> b) -> a -> b
$ \_req :: Request
_req -> ((Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ Response
res)
WPRProxyDest pd :: ProxyDest
pd -> (ProxyDest, Request, Bool)
-> Either Application (ProxyDest, Request, Bool)
forall a b. b -> Either a b
Right (ProxyDest
pd, Request
req0, Bool
False)
WPRProxyDestSecure pd :: ProxyDest
pd -> (ProxyDest, Request, Bool)
-> Either Application (ProxyDest, Request, Bool)
forall a b. b -> Either a b
Right (ProxyDest
pd, Request
req0, Bool
True)
WPRModifiedRequest req :: Request
req pd :: ProxyDest
pd -> (ProxyDest, Request, Bool)
-> Either Application (ProxyDest, Request, Bool)
forall a b. b -> Either a b
Right (ProxyDest
pd, Request
req, Bool
False)
WPRModifiedRequestSecure req :: Request
req pd :: ProxyDest
pd -> (ProxyDest, Request, Bool)
-> Either Application (ProxyDest, Request, Bool)
forall a b. b -> Either a b
Right (ProxyDest
pd, Request
req, Bool
True)
WPRApplication app :: Application
app -> Application -> Either Application (ProxyDest, Request, Bool)
forall a b. a -> Either a b
Left Application
app
timeBound :: Int -> IO ResponseReceived -> IO ResponseReceived
timeBound us :: Int
us f :: IO ResponseReceived
f =
Int -> IO ResponseReceived -> IO (Maybe ResponseReceived)
forall (m :: * -> *) a.
MonadUnliftIO m =>
Int -> m a -> m (Maybe a)
timeout Int
us IO ResponseReceived
f IO (Maybe ResponseReceived)
-> (Maybe ResponseReceived -> IO ResponseReceived)
-> IO ResponseReceived
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just res :: ResponseReceived
res -> ResponseReceived -> IO ResponseReceived
forall (m :: * -> *) a. Monad m => a -> m a
return ResponseReceived
res
Nothing -> Response -> IO ResponseReceived
sendResponse (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ Status -> RequestHeaders -> ByteString -> Response
WAI.responseLBS Status
HT.status500 [] "timeBound"
case Either Application (ProxyDest, Request, Bool)
edest of
Left app :: Application
app -> (IO ResponseReceived -> IO ResponseReceived)
-> (Int -> IO ResponseReceived -> IO ResponseReceived)
-> Maybe Int
-> IO ResponseReceived
-> IO ResponseReceived
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO ResponseReceived -> IO ResponseReceived
forall a. a -> a
id Int -> IO ResponseReceived -> IO ResponseReceived
timeBound (LocalWaiProxySettings -> Maybe Int
lpsTimeBound LocalWaiProxySettings
lps) (IO ResponseReceived -> IO ResponseReceived)
-> IO ResponseReceived -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ Application
app Request
req0 Response -> IO ResponseReceived
sendResponse
Right (ProxyDest host :: ByteString
host port :: Int
port, req :: Request
req, secure :: Bool
secure) -> WaiProxySettings
-> ByteString
-> Int
-> Request
-> (Response -> IO ResponseReceived)
-> IO ResponseReceived
-> IO ResponseReceived
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 (IO ResponseReceived -> IO ResponseReceived)
-> IO ResponseReceived -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ do
let req' :: Request
req' =
#if MIN_VERSION_http_client(0, 5, 0)
Request
HC.defaultRequest
{ checkResponse :: Request -> Response (IO ByteString) -> IO ()
HC.checkResponse = \_ _ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
, responseTimeout :: ResponseTimeout
HC.responseTimeout = ResponseTimeout
-> (Int -> ResponseTimeout) -> Maybe Int -> ResponseTimeout
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ResponseTimeout
HC.responseTimeoutNone Int -> ResponseTimeout
HC.responseTimeoutMicro (Maybe Int -> ResponseTimeout) -> Maybe Int -> ResponseTimeout
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 = 0
}
body :: RequestBody
body =
case Request -> RequestBodyLength
WAI.requestBodyLength Request
req of
WAI.KnownLength i :: Word64
i -> Int64 -> GivesPopper () -> RequestBody
HC.RequestBodyStream
(Word64 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
i)
((IO ByteString -> IO ()) -> IO ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ Request -> IO ByteString
WAI.requestBody Request
req)
WAI.ChunkedBody -> GivesPopper () -> RequestBody
HC.RequestBodyStreamChunked ((IO ByteString -> IO ()) -> IO ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ Request -> IO ByteString
WAI.requestBody Request
req)
IO (Either SomeException (Response (IO ByteString)))
-> (Either SomeException (Response (IO ByteString)) -> IO ())
-> (Either SomeException (Response (IO ByteString))
-> IO ResponseReceived)
-> IO ResponseReceived
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket
(IO (Response (IO ByteString))
-> IO (Either SomeException (Response (IO ByteString)))
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try (IO (Response (IO ByteString))
-> IO (Either SomeException (Response (IO ByteString))))
-> IO (Response (IO ByteString))
-> IO (Either SomeException (Response (IO ByteString)))
forall a b. (a -> b) -> a -> b
$ Request -> Manager -> IO (Response (IO ByteString))
HC.responseOpen Request
req' Manager
manager)
((SomeException -> IO ())
-> (Response (IO ByteString) -> IO ())
-> Either SomeException (Response (IO ByteString))
-> IO ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (IO () -> SomeException -> IO ()
forall a b. a -> b -> a
const (IO () -> SomeException -> IO ())
-> IO () -> SomeException -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) Response (IO ByteString) -> IO ()
forall a. Response a -> IO ()
HC.responseClose)
((Either SomeException (Response (IO ByteString))
-> IO ResponseReceived)
-> IO ResponseReceived)
-> (Either SomeException (Response (IO ByteString))
-> IO ResponseReceived)
-> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ \case
Left e :: SomeException
e -> WaiProxySettings -> SomeException -> Application
wpsOnExc WaiProxySettings
wps SomeException
e Request
req Response -> IO ResponseReceived
sendResponse
Right res :: Response (IO ByteString)
res -> do
let conduit :: ConduitT ByteString (Flush Builder) IO ()
conduit = ConduitT ByteString (Flush Builder) IO ()
-> Maybe (ConduitT ByteString (Flush Builder) IO ())
-> ConduitT ByteString (Flush Builder) IO ()
forall a. a -> Maybe a -> a
fromMaybe
((ByteString -> ConduitT ByteString (Flush Builder) IO ())
-> ConduitT ByteString (Flush Builder) IO ()
forall (m :: * -> *) i o r.
Monad m =>
(i -> ConduitT i o m r) -> ConduitT i o m ()
awaitForever (\bs :: ByteString
bs -> Flush Builder -> ConduitT ByteString (Flush Builder) IO ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield (Builder -> Flush Builder
forall a. a -> Flush a
Chunk (Builder -> Flush Builder) -> Builder -> Flush Builder
forall a b. (a -> b) -> a -> b
$ ByteString -> Builder
fromByteString ByteString
bs) ConduitT ByteString (Flush Builder) IO ()
-> ConduitT ByteString (Flush Builder) IO ()
-> ConduitT ByteString (Flush Builder) IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Flush Builder -> ConduitT ByteString (Flush Builder) IO ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield Flush Builder
forall a. Flush a
Flush))
(WaiProxySettings
-> Request
-> Response ()
-> Maybe (ConduitT ByteString (Flush Builder) IO ())
wpsProcessBody WaiProxySettings
wps Request
req (Response () -> Maybe (ConduitT ByteString (Flush Builder) IO ()))
-> Response () -> Maybe (ConduitT ByteString (Flush Builder) IO ())
forall a b. (a -> b) -> a -> b
$ () -> IO ByteString -> ()
forall a b. a -> b -> a
const () (IO ByteString -> ()) -> Response (IO ByteString) -> Response ()
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Response (IO ByteString)
res)
src :: ConduitT i ByteString IO ()
src = IO ByteString -> ConduitT i ByteString IO ()
forall (m :: * -> *) i.
MonadIO m =>
IO ByteString -> ConduitT i ByteString m ()
bodyReaderSource (IO ByteString -> ConduitT i ByteString IO ())
-> IO ByteString -> ConduitT i ByteString IO ()
forall a b. (a -> b) -> a -> b
$ Response (IO ByteString) -> IO ByteString
forall body. Response body -> body
HC.responseBody Response (IO ByteString)
res
Response -> IO ResponseReceived
sendResponse (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ Status -> RequestHeaders -> StreamingBody -> Response
WAI.responseStream
(Response (IO ByteString) -> Status
forall body. Response body -> Status
HC.responseStatus Response (IO ByteString)
res)
(((CI ByteString, ByteString) -> Bool)
-> RequestHeaders -> RequestHeaders
forall a. (a -> Bool) -> [a] -> [a]
filter (\(key :: CI ByteString
key, _) -> Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ CI ByteString
key CI ByteString -> Set (CI ByteString) -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set (CI ByteString)
strippedHeaders) (RequestHeaders -> RequestHeaders)
-> RequestHeaders -> RequestHeaders
forall a b. (a -> b) -> a -> b
$ Response (IO ByteString) -> RequestHeaders
forall body. Response body -> RequestHeaders
HC.responseHeaders Response (IO ByteString)
res)
(\sendChunk :: Builder -> IO ()
sendChunk flush :: IO ()
flush -> ConduitT () Void IO () -> IO ()
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit (ConduitT () Void IO () -> IO ())
-> ConduitT () Void IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ ConduitT () ByteString IO ()
forall i. ConduitT i ByteString IO ()
src ConduitT () ByteString IO ()
-> Sink ByteString IO () -> ConduitT () Void IO ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ConduitT ByteString (Flush Builder) IO ()
conduit ConduitT ByteString (Flush Builder) IO ()
-> ConduitM (Flush Builder) Void IO () -> Sink ByteString IO ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| (Flush Builder -> IO ()) -> ConduitM (Flush Builder) Void IO ()
forall (m :: * -> *) a o.
Monad m =>
(a -> m ()) -> ConduitT a o m ()
CL.mapM_ (\mb :: Flush Builder
mb ->
case Flush Builder
mb of
Flush -> IO ()
flush
Chunk b :: Builder
b -> Builder -> IO ()
sendChunk Builder
b))
getHeaders :: Monad m => ConduitT ByteString o m HT.RequestHeaders
=
ByteString -> RequestHeaders
toHeaders (ByteString -> RequestHeaders)
-> ConduitT ByteString o m ByteString
-> ConduitT ByteString o m RequestHeaders
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ByteString -> ByteString) -> ConduitT ByteString o m ByteString
forall (m :: * -> *) o.
Monad m =>
(ByteString -> ByteString) -> ConduitT ByteString o m ByteString
go ByteString -> ByteString
forall a. a -> a
id
where
go :: (ByteString -> ByteString) -> ConduitT ByteString o m ByteString
go front :: ByteString -> ByteString
front =
ConduitT ByteString o m (Maybe ByteString)
forall (m :: * -> *) i. Monad m => Consumer i m (Maybe i)
await ConduitT ByteString o m (Maybe ByteString)
-> (Maybe ByteString -> ConduitT ByteString o m ByteString)
-> ConduitT ByteString o m ByteString
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ConduitT ByteString o m ByteString
-> (ByteString -> ConduitT ByteString o m ByteString)
-> Maybe ByteString
-> ConduitT ByteString o m ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ConduitT ByteString o m ByteString
forall o (m :: * -> *). ConduitT ByteString o m ByteString
close ByteString -> ConduitT ByteString o m ByteString
push
where
close :: ConduitT ByteString o m ByteString
close = ByteString -> ConduitT ByteString o m ()
forall i o (m :: * -> *). i -> ConduitT i o m ()
leftover ByteString
bs ConduitT ByteString o m ()
-> ConduitT ByteString o m ByteString
-> ConduitT ByteString o m ByteString
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ByteString -> ConduitT ByteString o m ByteString
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 bs' :: ByteString
bs'
| "\r\n\r\n" ByteString -> ByteString -> Bool
`S8.isInfixOf` ByteString
bs
Bool -> Bool -> Bool
|| "\n\n" ByteString -> ByteString -> Bool
`S8.isInfixOf` ByteString
bs
Bool -> Bool -> Bool
|| ByteString -> Int
S8.length ByteString
bs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 4096 = ByteString -> ConduitT ByteString o m ()
forall i o (m :: * -> *). i -> ConduitT i o m ()
leftover ByteString
bs ConduitT ByteString o m ()
-> ConduitT ByteString o m ByteString
-> ConduitT ByteString o m ByteString
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ByteString -> ConduitT ByteString o m ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
bs
| Bool
otherwise = (ByteString -> ByteString) -> ConduitT ByteString o m ByteString
go ((ByteString -> ByteString) -> ConduitT ByteString o m ByteString)
-> (ByteString -> ByteString) -> ConduitT ByteString o m ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString -> ByteString
forall a. Monoid a => a -> a -> a
mappend ByteString
bs
where
bs :: ByteString
bs = ByteString -> ByteString
front ByteString
bs'
toHeaders :: ByteString -> RequestHeaders
toHeaders = (ByteString -> (CI ByteString, ByteString))
-> [ByteString] -> RequestHeaders
forall a b. (a -> b) -> [a] -> [b]
map ByteString -> (CI ByteString, ByteString)
toHeader ([ByteString] -> RequestHeaders)
-> (ByteString -> [ByteString]) -> ByteString -> RequestHeaders
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> Bool) -> [ByteString] -> [ByteString]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Bool -> Bool
not (Bool -> Bool) -> (ByteString -> Bool) -> ByteString -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Bool
S8.null) ([ByteString] -> [ByteString])
-> (ByteString -> [ByteString]) -> ByteString -> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [ByteString] -> [ByteString]
forall a. Int -> [a] -> [a]
drop 1 ([ByteString] -> [ByteString])
-> (ByteString -> [ByteString]) -> ByteString -> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
S8.lines
toHeader :: ByteString -> (CI ByteString, ByteString)
toHeader bs :: ByteString
bs =
(ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
CI.mk ByteString
key, ByteString
val)
where
(key :: ByteString
key, bs' :: ByteString
bs') = (Word8 -> Bool) -> ByteString -> (ByteString, ByteString)
S.break (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
_colon) ByteString
bs
val :: ByteString
val = (Word8 -> Bool) -> ByteString -> ByteString
S.takeWhile (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word8
_cr) (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ (Word8 -> Bool) -> ByteString -> ByteString
S.dropWhile Word8 -> Bool
isSpace (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
S.drop 1 ByteString
bs'
bodyReaderSource :: MonadIO m => BodyReader -> ConduitT i ByteString m ()
bodyReaderSource :: IO ByteString -> ConduitT i ByteString m ()
bodyReaderSource br :: IO ByteString
br =
ConduitT i ByteString m ()
forall i. ConduitT i ByteString m ()
loop
where
loop :: ConduitT i ByteString m ()
loop = do
ByteString
bs <- IO ByteString -> ConduitT i ByteString m ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> ConduitT i ByteString m ByteString)
-> IO ByteString -> ConduitT i ByteString m ByteString
forall a b. (a -> b) -> a -> b
$ IO ByteString -> IO ByteString
brRead IO ByteString
br
Bool -> ConduitT i ByteString m () -> ConduitT i ByteString m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Bool
S.null ByteString
bs) (ConduitT i ByteString m () -> ConduitT i ByteString m ())
-> ConduitT i ByteString m () -> ConduitT i ByteString m ()
forall a b. (a -> b) -> a -> b
$ do
ByteString -> ConduitT i ByteString m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield ByteString
bs
ConduitT i ByteString m ()
loop