{-# LANGUAGE DeriveGeneric         #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE LambdaCase            #-}
{-# LANGUAGE TupleSections         #-}
{-# LANGUAGE CPP                   #-}
module Network.HTTP.ReverseProxy
    ( -- * Types
      ProxyDest (..)
      -- * Raw
    , rawProxyTo
    , rawTcpProxyTo
      -- * WAI + http-conduit
    , waiProxyTo
    , defaultOnExc
    , waiProxyToSettings
    , WaiProxyResponse (..)
      -- ** Settings
    , WaiProxySettings
    , defaultWaiProxySettings
    , wpsOnExc
    , wpsTimeout
    , wpsSetIpHeader
    , wpsProcessBody
    , wpsUpgradeToRaw
    , wpsGetDest
    , SetIpHeader (..)
      -- *** Local settings
    , LocalWaiProxySettings
    , defaultLocalWaiProxySettings
    , setLpsTimeBound
    {- FIXME
      -- * WAI to Raw
    , waiToRaw
    -}
    ) 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_)

-- | Host\/port combination to which we want to proxy.
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)

-- | Set up a reverse proxy server, which will have a minimal overhead.
--
-- This function uses raw sockets, parsing as little of the request as
-- possible. The workflow is:
--
-- 1. Parse the first request headers.
--
-- 2. Ask the supplied function to specify how to reverse proxy.
--
-- 3. Open up a connection to the given host\/port.
--
-- 4. Pass all bytes across the wire unchanged.
--
-- If you need more control, such as modifying the request or response, use 'waiProxyTo'.
rawProxyTo :: MonadUnliftIO m
           => (HT.RequestHeaders -> m (Either (DCN.AppData -> m ()) ProxyDest))
           -- ^ How to reverse proxy. A @Left@ result will run the given
           -- 'DCN.Application', whereas a @Right@ will reverse proxy to the
           -- given host\/port.
           -> 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
            -- We know that the socket will be closed by the toClient side, so
            -- we can throw away the finalizer here.
            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

-- | Set up a reverse tcp proxy server, which will have a minimal overhead.
--
-- This function uses raw sockets, parsing as little of the request as
-- possible. The workflow is:
--
-- 1. Open up a connection to the given host\/port.
--
-- 2. Pass all bytes across the wire unchanged.
--
-- If you need more control, such as modifying the request or response, use 'waiProxyTo'.
--
-- Since 0.4.4
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      )

-- | Sends a simple 502 bad gateway error message with the contents of the
-- exception.
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))

-- | The different responses that could be generated by a @waiProxyTo@ lookup
-- function.
--
-- Since 0.2.0
data WaiProxyResponse = WPRResponse WAI.Response
                        -- ^ Respond with the given WAI Response.
                        --
                        -- Since 0.2.0
                      | WPRProxyDest ProxyDest
                        -- ^ Send to the given destination.
                        --
                        -- Since 0.2.0
                      | WPRProxyDestSecure ProxyDest
                        -- ^ Send to the given destination via HTTPS.
                      | WPRModifiedRequest WAI.Request ProxyDest
                        -- ^ Send to the given destination, but use the given
                        -- modified Request for computing the reverse-proxied
                        -- request. This can be useful for reverse proxying to
                        -- a different path than the one specified. By the
                        -- user.
                        --
                        -- Since 0.2.0
                      | WPRModifiedRequestSecure WAI.Request ProxyDest
                        -- ^ Same as WPRModifiedRequest but send to the
                        -- given destination via HTTPS.
                      | WPRApplication WAI.Application
                        -- ^ Respond with the given WAI Application.
                        --
                        -- Since 0.4.0

-- | Creates a WAI 'WAI.Application' which will handle reverse proxies.
--
-- Connections to the proxied server will be provided via http-conduit. As
-- such, all requests and responses will be fully processed in your reverse
-- proxy. This allows you much more control over the data sent over the wire,
-- but also incurs overhead. For a lower-overhead approach, consider
-- 'rawProxyTo'.
--
-- Most likely, the given application should be run with Warp, though in theory
-- other WAI handlers will work as well.
--
-- Note: This function will use chunked request bodies for communicating with
-- the proxied server. Not all servers necessarily support chunked request
-- bodies, so please confirm that yours does (Warp, Snap, and Happstack, for example, do).
waiProxyTo :: (WAI.Request -> IO WaiProxyResponse)
           -- ^ How to reverse proxy.
           -> (SomeException -> WAI.Application)
           -- ^ How to handle exceptions when calling remote server. For a
           -- simple 502 error page, use 'defaultOnExc'.
           -> HC.Manager -- ^ connection manager to utilize
           -> 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
    -- ^ Allows to specify the maximum time allowed for the conection on per request basis.
    --
    -- Default: no timeouts
    --
    -- Since 0.4.2
    }

-- | Default value for 'LocalWaiProxySettings', same as 'def' but with a more explicit name.
--
-- Since 0.4.2
defaultLocalWaiProxySettings :: LocalWaiProxySettings
defaultLocalWaiProxySettings :: LocalWaiProxySettings
defaultLocalWaiProxySettings = Maybe Int -> LocalWaiProxySettings
LocalWaiProxySettings Maybe Int
forall a. Maybe a
Nothing

-- | Allows to specify the maximum time allowed for the conection on per request basis.
--
-- Default: no timeouts
--
-- Since 0.4.2
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
    , WaiProxySettings -> SetIpHeader
wpsSetIpHeader :: SetIpHeader
    -- ^ Set the X-Real-IP request header with the client's IP address.
    --
    -- Default: SIHFromSocket
    --
    -- Since 0.2.0
    , WaiProxySettings
-> Request
-> Response ()
-> Maybe (ConduitT ByteString (Flush Builder) IO ())
wpsProcessBody :: WAI.Request -> HC.Response () -> Maybe (ConduitT ByteString (Flush Builder) IO ())
    -- ^ Post-process the response body returned from the host.
    --   The API for this function changed to include the extra 'WAI.Request'
    --   parameter in version 0.5.0.
    --
    -- Since 0.2.1
    , WaiProxySettings -> Request -> Bool
wpsUpgradeToRaw :: WAI.Request -> Bool
    -- ^ Determine if the request should be upgraded to a raw proxy connection,
    -- as is needed for WebSockets. Requires WAI 2.1 or higher and a WAI
    -- handler with raw response support (e.g., Warp) to work.
    --
    -- Default: check if the upgrade header is websocket.
    --
    -- Since 0.3.1
    , WaiProxySettings
-> Maybe (Request -> IO (LocalWaiProxySettings, WaiProxyResponse))
wpsGetDest :: Maybe (WAI.Request -> IO (LocalWaiProxySettings, WaiProxyResponse))
    -- ^ Allow to override proxy settings for each request.
    -- If you supply this field it will take precedence over
    -- getDest parameter in waiProxyToSettings
    --
    -- Default: have one global setting
    --
    -- Since 0.4.2
    }

-- | How to set the X-Real-IP request header.
--
-- Since 0.2.0
data SetIpHeader = SIHNone -- ^ Do not set the header
                 | SIHFromSocket -- ^ Set it from the socket's address.
                 | SIHFromHeader -- ^ Set it from either X-Real-IP or X-Forwarded-For, if present

-- | Default value for 'WaiProxySettings'
--
-- @since 0.6.0
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
renderHeaders :: Request -> RequestHeaders -> Builder
renderHeaders 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
strippedHeaders :: Set (CI ByteString)
strippedHeaders = [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
fixReqHeaders :: WaiProxySettings -> Request -> RequestHeaders
fixReqHeaders 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))

-- | Get the HTTP headers for the first request on the stream, returning on
-- consumed bytes as leftovers. Has built-in limits on how many bytes it will
-- consume (specifically, will not ask for another chunked after it receives
-- 1000 bytes).
getHeaders :: Monad m => ConduitT ByteString o m HT.RequestHeaders
getHeaders :: ConduitT ByteString o m RequestHeaders
getHeaders =
    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'

{- FIXME
-- | Convert a WAI application into a raw application, using Warp.
waiToRaw :: WAI.Application -> DCN.Application IO
waiToRaw app appdata0 =
    loop fromClient0
  where
    fromClient0 = DCN.appSource appdata0
    toClient = DCN.appSink appdata0
    loop fromClient = do
        mfromClient <- runResourceT $ withInternalState $ \internalState -> do
            ex <- try $ parseRequest conn internalState dummyAddr fromClient
            case ex of
                Left (_ :: SomeException) -> return Nothing
                Right (req, fromClient') -> do
                    res <- app req
                    keepAlive <- sendResponse
                        defaultSettings
                        req conn res
                    (fromClient'', _) <- liftIO fromClient' >>= unwrapResumable
                    return $ if keepAlive then Just fromClient'' else Nothing
        maybe (return ()) loop mfromClient

    dummyAddr = SockAddrInet (PortNum 0) 0 -- FIXME
    conn = Connection
        { connSendMany = \bss -> mapM_ yield bss $$ toClient
        , connSendAll = \bs -> yield bs $$ toClient
        , connSendFile = \fp offset len _th headers _cleaner ->
            let src1 = mapM_ yield headers
                src2 = sourceFileRange fp (Just offset) (Just len)
             in runResourceT
                $  (src1 >> src2)
                $$ transPipe lift toClient
        , connClose = return ()
        , connRecv = error "connRecv should not be used"
        }
        -}

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