{-# 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
    , wpsLogRequest
    , 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.List.NonEmpty             (NonEmpty (..))
import qualified Data.List.NonEmpty             as NE
import           Data.Maybe                     (fromMaybe, listToMaybe)
import           Data.Monoid                    (mappend, mconcat, (<>))
import           Data.Set                       (Set)
import qualified Data.Set                       as Set
import           Data.Streaming.Network         (AppData, readLens)
import qualified Data.Text.Lazy                 as TL
import qualified Data.Text.Lazy.Encoding        as TLE
import qualified Data.Text                      as T
import qualified Data.Text.Encoding             as TE
import           Data.Word8                     (isSpace, _colon, _cr)
import           GHC.Generics                   (Generic)
import           Network.HTTP.Client            (BodyReader, brRead)
import qualified Network.HTTP.Client            as HC
import qualified Network.HTTP.Types             as HT
import qualified Network.Wai                    as WAI
import           Network.Wai.Logger             (showSockAddr)
import           UnliftIO                       (MonadIO, liftIO, MonadUnliftIO, timeout, SomeException, try, bracket, concurrently_)

-- | 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]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [ProxyDest]
$creadListPrec :: ReadPrec [ProxyDest]
readPrec :: ReadPrec ProxyDest
$creadPrec :: ReadPrec ProxyDest
readList :: ReadS [ProxyDest]
$creadList :: ReadS [ProxyDest]
readsPrec :: Int -> ReadS ProxyDest
$creadsPrec :: Int -> ReadS ProxyDest
Read, Int -> ProxyDest -> ShowS
[ProxyDest] -> ShowS
ProxyDest -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ProxyDest] -> ShowS
$cshowList :: [ProxyDest] -> ShowS
show :: ProxyDest -> String
$cshow :: ProxyDest -> String
showsPrec :: Int -> ProxyDest -> ShowS
$cshowsPrec :: Int -> ProxyDest -> ShowS
Show, ProxyDest -> ProxyDest -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ProxyDest -> ProxyDest -> Bool
$c/= :: ProxyDest -> ProxyDest -> Bool
== :: ProxyDest -> ProxyDest -> Bool
$c== :: ProxyDest -> ProxyDest -> Bool
Eq, Eq ProxyDest
ProxyDest -> ProxyDest -> Bool
ProxyDest -> ProxyDest -> Ordering
ProxyDest -> ProxyDest -> ProxyDest
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ProxyDest -> ProxyDest -> ProxyDest
$cmin :: ProxyDest -> ProxyDest -> ProxyDest
max :: ProxyDest -> ProxyDest -> ProxyDest
$cmax :: ProxyDest -> ProxyDest -> ProxyDest
>= :: ProxyDest -> ProxyDest -> Bool
$c>= :: ProxyDest -> ProxyDest -> Bool
> :: ProxyDest -> ProxyDest -> Bool
$c> :: ProxyDest -> ProxyDest -> Bool
<= :: ProxyDest -> ProxyDest -> Bool
$c<= :: ProxyDest -> ProxyDest -> Bool
< :: ProxyDest -> ProxyDest -> Bool
$c< :: ProxyDest -> ProxyDest -> Bool
compare :: ProxyDest -> ProxyDest -> Ordering
$ccompare :: ProxyDest -> ProxyDest -> Ordering
Ord, forall x. Rep ProxyDest x -> ProxyDest
forall x. ProxyDest -> Rep ProxyDest x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ProxyDest x -> ProxyDest
$cfrom :: forall x. ProxyDest -> Rep ProxyDest x
Generic)

-- | 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 :: forall (m :: * -> *).
MonadUnliftIO m =>
(RequestHeaders -> m (Either (AppData -> m ()) ProxyDest))
-> AppData -> m ()
rawProxyTo RequestHeaders -> m (Either (AppData -> m ()) ProxyDest)
getDest AppData
appdata = do
    (SealedConduitT () ByteString IO ()
rsrc, RequestHeaders
headers) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall {i}. ConduitT i ByteString IO ()
fromClient forall (m :: * -> *) a b.
Monad m =>
ConduitT () a m ()
-> ConduitT a Void m b -> m (SealedConduitT () a m (), b)
$$+ forall (m :: * -> *) o.
Monad m =>
ConduitT ByteString o m RequestHeaders
getHeaders
    Either (AppData -> m ()) ProxyDest
edest <- RequestHeaders -> m (Either (AppData -> m ()) ProxyDest)
getDest RequestHeaders
headers
    case Either (AppData -> m ()) ProxyDest
edest of
        Left AppData -> m ()
app -> do
            -- 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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (IORef a)
newIORef SealedConduitT () ByteString IO ()
rsrc
            let readData :: IO ByteString
readData = do
                    SealedConduitT () ByteString IO ()
rsrc1 <- forall a. IORef a -> IO a
readIORef IORef (SealedConduitT () ByteString IO ())
irsrc
                    (SealedConduitT () ByteString IO ()
rsrc2, Maybe ByteString
mbs) <- SealedConduitT () ByteString IO ()
rsrc1 forall (m :: * -> *) a b.
Monad m =>
SealedConduitT () a m ()
-> ConduitT a Void m b -> m (SealedConduitT () a m (), b)
$$++ forall (m :: * -> *) i o. Monad m => ConduitT i o m (Maybe i)
await
                    forall a. IORef a -> a -> IO ()
writeIORef IORef (SealedConduitT () ByteString IO ())
irsrc SealedConduitT () ByteString IO ()
rsrc2
                    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe ByteString
"" Maybe ByteString
mbs
            AppData -> m ()
app forall a b. (a -> b) -> a -> b
$ forall a. Identity a -> a
runIdentity (forall a (f :: * -> *).
(HasReadWrite a, Functor f) =>
(IO ByteString -> f (IO ByteString)) -> a -> f a
readLens (forall a b. a -> b -> a
const (forall a. a -> Identity a
Identity IO ByteString
readData)) AppData
appdata)


        Right (ProxyDest ByteString
host Int
port) -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. ClientSettings -> (AppData -> IO a) -> IO a
DCN.runTCPClient (Int -> ByteString -> ClientSettings
DCN.clientSettings Int
port ByteString
host) (forall {p}.
HasReadWrite p =>
SealedConduitT () ByteString IO () -> p -> IO ()
withServer SealedConduitT () ByteString IO ()
rsrc)
  where
    fromClient :: ConduitT i ByteString IO ()
fromClient = forall ad (m :: * -> *) i.
(HasReadWrite ad, MonadIO m) =>
ad -> ConduitT i ByteString m ()
DCN.appSource AppData
appdata
    toClient :: ConduitT ByteString o IO ()
toClient = forall ad (m :: * -> *) o.
(HasReadWrite ad, MonadIO m) =>
ad -> ConduitT ByteString o m ()
DCN.appSink AppData
appdata
    withServer :: SealedConduitT () ByteString IO () -> p -> IO ()
withServer SealedConduitT () ByteString IO ()
rsrc p
appdataServer = forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m ()
concurrently_
        (SealedConduitT () ByteString IO ()
rsrc forall (m :: * -> *) a b.
Monad m =>
SealedConduitT () a m () -> ConduitT a Void m b -> m b
$$+- forall {o}. ConduitT ByteString o IO ()
toServer)
        (forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit forall a b. (a -> b) -> a -> b
$ forall {i}. ConduitT i ByteString IO ()
fromServer forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall {o}. ConduitT ByteString o IO ()
toClient)
      where
        fromServer :: ConduitT i ByteString IO ()
fromServer = forall ad (m :: * -> *) i.
(HasReadWrite ad, MonadIO m) =>
ad -> ConduitT i ByteString m ()
DCN.appSource p
appdataServer
        toServer :: ConduitT ByteString o IO ()
toServer = forall ad (m :: * -> *) o.
(HasReadWrite ad, MonadIO m) =>
ad -> ConduitT ByteString o m ()
DCN.appSink p
appdataServer

-- | 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 :: forall (m :: * -> *). MonadIO m => ProxyDest -> AppData -> m ()
rawTcpProxyTo (ProxyDest ByteString
host Int
port) AppData
appdata = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
    forall a. ClientSettings -> (AppData -> IO a) -> IO a
DCN.runTCPClient (Int -> ByteString -> ClientSettings
DCN.clientSettings Int
port ByteString
host) forall {m :: * -> *} {ad}.
(MonadUnliftIO m, HasReadWrite ad) =>
ad -> m ()
withServer
  where
    withServer :: ad -> m ()
withServer ad
appdataServer = forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m ()
concurrently_
      (forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit forall a b. (a -> b) -> a -> b
$ forall ad (m :: * -> *) i.
(HasReadWrite ad, MonadIO m) =>
ad -> ConduitT i ByteString m ()
DCN.appSource AppData
appdata       forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall ad (m :: * -> *) o.
(HasReadWrite ad, MonadIO m) =>
ad -> ConduitT ByteString o m ()
DCN.appSink ad
appdataServer)
      (forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit forall a b. (a -> b) -> a -> b
$ forall ad (m :: * -> *) i.
(HasReadWrite ad, MonadIO m) =>
ad -> ConduitT i ByteString m ()
DCN.appSource ad
appdataServer forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall ad (m :: * -> *) o.
(HasReadWrite ad, MonadIO m) =>
ad -> ConduitT ByteString o m ()
DCN.appSink AppData
appdata      )

-- | Sends a simple 502 bad gateway error message with the contents of the
-- exception.
defaultOnExc :: SomeException -> WAI.Application
defaultOnExc :: SomeException -> Application
defaultOnExc SomeException
exc Request
_ Response -> IO ResponseReceived
sendResponse = Response -> IO ResponseReceived
sendResponse forall a b. (a -> b) -> a -> b
$ Status -> RequestHeaders -> ByteString -> Response
WAI.responseLBS
    Status
HT.status502
    [(HeaderName
"content-type", ByteString
"text/plain")]
    (ByteString
"Error connecting to gateway:\n\n" forall a. Semigroup a => a -> a -> a
<> Text -> ByteString
TLE.encodeUtf8 (String -> Text
TL.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show SomeException
exc))

-- | 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.
                        -- The path will be taken from rawPathInfo while
                        -- the queryString from rawQueryString of the
                        -- request.
                        --
                        -- @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 Request -> IO WaiProxyResponse
getDest SomeException -> Application
onError = (Request -> IO WaiProxyResponse)
-> WaiProxySettings -> Manager -> Application
waiProxyToSettings Request -> IO WaiProxyResponse
getDest WaiProxySettings
defaultWaiProxySettings { wpsOnExc :: SomeException -> Application
wpsOnExc = SomeException -> Application
onError }

data LocalWaiProxySettings = LocalWaiProxySettings
    { LocalWaiProxySettings -> Maybe Int
lpsTimeBound :: Maybe Int
    -- ^ 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 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 Maybe Int
x LocalWaiProxySettings
s = LocalWaiProxySettings
s { lpsTimeBound :: Maybe Int
lpsTimeBound = Maybe Int
x }

data WaiProxySettings = WaiProxySettings
    { WaiProxySettings -> SomeException -> Application
wpsOnExc :: SomeException -> WAI.Application
    , WaiProxySettings -> Maybe Int
wpsTimeout :: Maybe Int
    , 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
    , WaiProxySettings -> Request -> IO ()
wpsLogRequest :: HC.Request -> IO ()
    -- ^ Function provided to log the 'Request' that is constructed.
    --
    -- Default: no op
    --
    -- @since 0.6.0.1
    }

-- | 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
        { wpsOnExc :: SomeException -> Application
wpsOnExc = SomeException -> Application
defaultOnExc
        , wpsTimeout :: Maybe Int
wpsTimeout = forall a. Maybe a
Nothing
        , wpsSetIpHeader :: SetIpHeader
wpsSetIpHeader = SetIpHeader
SIHFromSocket
        , wpsProcessBody :: Request
-> Response () -> Maybe (ConduitT ByteString (Flush Builder) IO ())
wpsProcessBody = \Request
_ Response ()
_ -> forall a. Maybe a
Nothing
        , wpsUpgradeToRaw :: Request -> Bool
wpsUpgradeToRaw = \Request
req ->
            (forall s. FoldCase s => s -> CI s
CI.mk forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
"upgrade" (Request -> RequestHeaders
WAI.requestHeaders Request
req)) forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just HeaderName
"websocket"
        , wpsGetDest :: Maybe (Request -> IO (LocalWaiProxySettings, WaiProxyResponse))
wpsGetDest = forall a. Maybe a
Nothing
        , wpsLogRequest :: Request -> IO ()
wpsLogRequest = forall a b. a -> b -> a
const (forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
        }

renderHeaders :: WAI.Request -> HT.RequestHeaders -> Builder
renderHeaders :: Request -> RequestHeaders -> Builder
renderHeaders Request
req RequestHeaders
headers
    = ByteString -> Builder
fromByteString (Request -> ByteString
WAI.requestMethod Request
req)
   forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
fromByteString ByteString
" "
   forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
fromByteString (Request -> ByteString
WAI.rawPathInfo Request
req)
   forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
fromByteString (Request -> ByteString
WAI.rawQueryString Request
req)
   forall a. Semigroup a => a -> a -> a
<> (if Request -> HttpVersion
WAI.httpVersion Request
req forall a. Eq a => a -> a -> Bool
== HttpVersion
HT.http11
           then ByteString -> Builder
fromByteString ByteString
" HTTP/1.1"
           else ByteString -> Builder
fromByteString ByteString
" HTTP/1.0")
   forall a. Semigroup a => a -> a -> a
<> forall a. Monoid a => [a] -> a
mconcat (forall a b. (a -> b) -> [a] -> [b]
map (HeaderName, ByteString) -> Builder
goHeader RequestHeaders
headers)
   forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
fromByteString ByteString
"\r\n\r\n"
  where
    goHeader :: (HeaderName, ByteString) -> Builder
goHeader (HeaderName
x, ByteString
y)
        = ByteString -> Builder
fromByteString ByteString
"\r\n"
       forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
fromByteString (forall s. CI s -> s
CI.original HeaderName
x)
       forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
fromByteString ByteString
": "
       forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
fromByteString ByteString
y

tryWebSockets :: WaiProxySettings -> ByteString -> Int -> WAI.Request -> (WAI.Response -> IO b) -> IO b -> IO b
tryWebSockets :: forall b.
WaiProxySettings
-> ByteString
-> Int
-> Request
-> (Response -> IO b)
-> IO b
-> IO b
tryWebSockets WaiProxySettings
wps ByteString
host Int
port Request
req Response -> IO b
sendResponse IO b
fallback
    | WaiProxySettings -> Request -> Bool
wpsUpgradeToRaw WaiProxySettings
wps Request
req =
        Response -> IO b
sendResponse forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip (IO ByteString -> (ByteString -> IO ()) -> IO ())
-> Response -> Response
WAI.responseRaw Response
backup forall a b. (a -> b) -> a -> b
$ \IO ByteString
fromClientBody ByteString -> IO ()
toClient ->
            forall a. ClientSettings -> (AppData -> IO a) -> IO a
DCN.runTCPClient ClientSettings
settings forall a b. (a -> b) -> a -> b
$ \AppData
server ->
                let toServer :: ConduitT ByteString o IO ()
toServer = forall ad (m :: * -> *) o.
(HasReadWrite ad, MonadIO m) =>
ad -> ConduitT ByteString o m ()
DCN.appSink AppData
server
                    fromServer :: ConduitT i ByteString IO ()
fromServer = forall ad (m :: * -> *) i.
(HasReadWrite ad, MonadIO m) =>
ad -> ConduitT i ByteString m ()
DCN.appSource AppData
server
                    fromClient :: ConduitT i ByteString IO ()
fromClient = do
                        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield forall a b. (a -> b) -> a -> b
$ ByteString -> [ByteString]
L.toChunks forall a b. (a -> b) -> a -> b
$ Builder -> ByteString
toLazyByteString Builder
headers
                        let loop :: ConduitT i ByteString IO ()
loop = do
                                ByteString
bs <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ByteString
fromClientBody
                                forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Bool
S.null ByteString
bs) forall a b. (a -> b) -> a -> b
$ do
                                    forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield ByteString
bs
                                    ConduitT i ByteString IO ()
loop
                        forall {i}. ConduitT i ByteString IO ()
loop
                    toClient' :: ConduitT ByteString o IO ()
toClient' = forall (m :: * -> *) i o r.
Monad m =>
(i -> ConduitT i o m r) -> ConduitT i o m ()
awaitForever forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> IO ()
toClient
                    headers :: Builder
headers = Request -> RequestHeaders -> Builder
renderHeaders Request
req forall a b. (a -> b) -> a -> b
$ WaiProxySettings -> Request -> RequestHeaders
fixReqHeaders WaiProxySettings
wps Request
req
                 in forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m ()
concurrently_
                        (forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit forall a b. (a -> b) -> a -> b
$ forall {i}. ConduitT i ByteString IO ()
fromClient forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall {o}. ConduitT ByteString o IO ()
toServer)
                        (forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit forall a b. (a -> b) -> a -> b
$ forall {i}. ConduitT i ByteString IO ()
fromServer forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall {o}. ConduitT ByteString o IO ()
toClient')
    | Bool
otherwise = IO b
fallback
  where
    backup :: Response
backup = Status -> RequestHeaders -> ByteString -> Response
WAI.responseLBS Status
HT.status500 [(HeaderName
"Content-Type", ByteString
"text/plain")]
        ByteString
"http-reverse-proxy detected WebSockets request, but server does not support responseRaw"
    settings :: ClientSettings
settings = Int -> ByteString -> ClientSettings
DCN.clientSettings Int
port ByteString
host

strippedHeaders :: Set HT.HeaderName
strippedHeaders :: Set HeaderName
strippedHeaders = forall a. Ord a => [a] -> Set a
Set.fromList
    [HeaderName
"content-length", HeaderName
"transfer-encoding", HeaderName
"accept-encoding", HeaderName
"content-encoding"]

fixReqHeaders :: WaiProxySettings -> WAI.Request -> HT.RequestHeaders
fixReqHeaders :: WaiProxySettings -> Request -> RequestHeaders
fixReqHeaders WaiProxySettings
wps Request
req =
    RequestHeaders -> RequestHeaders
addXRealIP forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (\(HeaderName
key, ByteString
value) -> Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ HeaderName
key forall a. Ord a => a -> Set a -> Bool
`Set.member` Set HeaderName
strippedHeaders
                                       Bool -> Bool -> Bool
|| (HeaderName
key forall a. Eq a => a -> a -> Bool
== HeaderName
"connection" Bool -> Bool -> Bool
&& ByteString
value forall a. Eq a => a -> a -> Bool
== ByteString
"close"))
               forall a b. (a -> b) -> a -> b
$ Request -> RequestHeaders
WAI.requestHeaders Request
req
  where
    fromSocket :: RequestHeaders -> RequestHeaders
fromSocket = ((HeaderName
"X-Real-IP", String -> ByteString
S8.pack forall a b. (a -> b) -> a -> b
$ SockAddr -> String
showSockAddr forall a b. (a -> b) -> a -> b
$ Request -> SockAddr
WAI.remoteHost Request
req)forall a. a -> [a] -> [a]
:)
    fromForwardedFor :: Maybe ByteString
fromForwardedFor = do
      ByteString
h <- forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
"x-forwarded-for" (Request -> RequestHeaders
WAI.requestHeaders Request
req)
      forall a. [a] -> Maybe a
listToMaybe forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Text -> ByteString
TE.encodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.strip) forall a b. (a -> b) -> a -> b
$ Text -> Text -> [Text]
T.splitOn Text
"," forall a b. (a -> b) -> a -> b
$ ByteString -> Text
TE.decodeUtf8 ByteString
h
    addXRealIP :: RequestHeaders -> RequestHeaders
addXRealIP =
        case WaiProxySettings -> SetIpHeader
wpsSetIpHeader WaiProxySettings
wps of
            SetIpHeader
SIHFromSocket -> RequestHeaders -> RequestHeaders
fromSocket
            SetIpHeader
SIHFromHeader ->
                case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
"x-real-ip" (Request -> RequestHeaders
WAI.requestHeaders Request
req) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe ByteString
fromForwardedFor of
                    Maybe ByteString
Nothing -> RequestHeaders -> RequestHeaders
fromSocket
                    Just ByteString
ip -> ((HeaderName
"X-Real-IP", ByteString
ip)forall a. a -> [a] -> [a]
:)
            SetIpHeader
SIHNone -> forall a. a -> a
id

waiProxyToSettings :: (WAI.Request -> IO WaiProxyResponse)
                   -> WaiProxySettings
                   -> HC.Manager
                   -> WAI.Application
waiProxyToSettings :: (Request -> IO WaiProxyResponse)
-> WaiProxySettings -> Manager -> Application
waiProxyToSettings Request -> IO WaiProxyResponse
getDest WaiProxySettings
wps' Manager
manager Request
req0 Response -> IO ResponseReceived
sendResponse = do
    let wps :: WaiProxySettings
wps = WaiProxySettings
wps'{wpsGetDest :: Maybe (Request -> IO (LocalWaiProxySettings, WaiProxyResponse))
wpsGetDest = WaiProxySettings
-> Maybe (Request -> IO (LocalWaiProxySettings, WaiProxyResponse))
wpsGetDest WaiProxySettings
wps' forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall a. a -> Maybe a
Just (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe Int -> LocalWaiProxySettings
LocalWaiProxySettings forall a b. (a -> b) -> a -> b
$ WaiProxySettings -> Maybe Int
wpsTimeout WaiProxySettings
wps',) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> IO WaiProxyResponse
getDest)}
    (LocalWaiProxySettings
lps, WaiProxyResponse
edest') <- forall a. a -> Maybe a -> a
fromMaybe
        (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return (LocalWaiProxySettings
defaultLocalWaiProxySettings, Response -> WaiProxyResponse
WPRResponse forall a b. (a -> b) -> a -> b
$ Status -> RequestHeaders -> ByteString -> Response
WAI.responseLBS Status
HT.status500 [] ByteString
"proxy not setup"))
        (WaiProxySettings
-> Maybe (Request -> IO (LocalWaiProxySettings, WaiProxyResponse))
wpsGetDest WaiProxySettings
wps)
        Request
req0
    let edest :: Either Application (ProxyDest, Request, Bool)
edest =
            case WaiProxyResponse
edest' of
                WPRResponse Response
res -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ \Request
_req -> (forall a b. (a -> b) -> a -> b
$ Response
res)
                WPRProxyDest ProxyDest
pd -> forall a b. b -> Either a b
Right (ProxyDest
pd, Request
req0, Bool
False)
                WPRProxyDestSecure ProxyDest
pd -> forall a b. b -> Either a b
Right (ProxyDest
pd, Request
req0, Bool
True)
                WPRModifiedRequest Request
req ProxyDest
pd -> forall a b. b -> Either a b
Right (ProxyDest
pd, Request
req, Bool
False)
                WPRModifiedRequestSecure Request
req ProxyDest
pd -> forall a b. b -> Either a b
Right (ProxyDest
pd, Request
req, Bool
True)
                WPRApplication Application
app -> forall a b. a -> Either a b
Left Application
app
        timeBound :: Int -> IO ResponseReceived -> IO ResponseReceived
timeBound Int
us IO ResponseReceived
f =
            forall (m :: * -> *) a.
MonadUnliftIO m =>
Int -> m a -> m (Maybe a)
timeout Int
us IO ResponseReceived
f forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                Just ResponseReceived
res -> forall (m :: * -> *) a. Monad m => a -> m a
return ResponseReceived
res
                Maybe ResponseReceived
Nothing -> Response -> IO ResponseReceived
sendResponse forall a b. (a -> b) -> a -> b
$ Status -> RequestHeaders -> ByteString -> Response
WAI.responseLBS Status
HT.status500 [] ByteString
"timeBound"
    case Either Application (ProxyDest, Request, Bool)
edest of
        Left Application
app -> forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id Int -> IO ResponseReceived -> IO ResponseReceived
timeBound (LocalWaiProxySettings -> Maybe Int
lpsTimeBound LocalWaiProxySettings
lps) forall a b. (a -> b) -> a -> b
$ Application
app Request
req0 Response -> IO ResponseReceived
sendResponse
        Right (ProxyDest ByteString
host Int
port, Request
req, Bool
secure) -> forall b.
WaiProxySettings
-> ByteString
-> Int
-> Request
-> (Response -> IO b)
-> IO b
-> IO b
tryWebSockets WaiProxySettings
wps ByteString
host Int
port Request
req Response -> IO ResponseReceived
sendResponse forall a b. (a -> b) -> a -> b
$ do
            GivesPopper ()
scb <- IO ByteString -> IO (GivesPopper ())
semiCachedBody (Request -> IO ByteString
WAI.requestBody Request
req)
            let body :: RequestBody
body =
                  case Request -> RequestBodyLength
WAI.requestBodyLength Request
req of
                      WAI.KnownLength Word64
i -> Int64 -> GivesPopper () -> RequestBody
HC.RequestBodyStream (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
i) GivesPopper ()
scb
                      RequestBodyLength
WAI.ChunkedBody -> GivesPopper () -> RequestBody
HC.RequestBodyStreamChunked GivesPopper ()
scb

            let req' :: Request
req' =
#if MIN_VERSION_http_client(0, 5, 0)
                  Request
HC.defaultRequest
                    { checkResponse :: Request -> Response (IO ByteString) -> IO ()
HC.checkResponse = \Request
_ Response (IO ByteString)
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
                    , responseTimeout :: ResponseTimeout
HC.responseTimeout = forall b a. b -> (a -> b) -> Maybe a -> b
maybe ResponseTimeout
HC.responseTimeoutNone Int -> ResponseTimeout
HC.responseTimeoutMicro forall a b. (a -> b) -> a -> b
$ LocalWaiProxySettings -> Maybe Int
lpsTimeBound LocalWaiProxySettings
lps
#else
                  def
                    { HC.checkStatus = \_ _ _ -> Nothing
                    , HC.responseTimeout = lpsTimeBound lps
#endif
                    , method :: ByteString
HC.method = Request -> ByteString
WAI.requestMethod Request
req
                    , secure :: Bool
HC.secure = Bool
secure
                    , host :: ByteString
HC.host = ByteString
host
                    , port :: Int
HC.port = Int
port
                    , path :: ByteString
HC.path = Request -> ByteString
WAI.rawPathInfo Request
req
                    , queryString :: ByteString
HC.queryString = Request -> ByteString
WAI.rawQueryString Request
req
                    , requestHeaders :: RequestHeaders
HC.requestHeaders = WaiProxySettings -> Request -> RequestHeaders
fixReqHeaders WaiProxySettings
wps Request
req
                    , requestBody :: RequestBody
HC.requestBody = RequestBody
body
                    , redirectCount :: Int
HC.redirectCount = Int
0
                    }
            forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket
                (forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try forall a b. (a -> b) -> a -> b
$ do
                   forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ WaiProxySettings -> Request -> IO ()
wpsLogRequest WaiProxySettings
wps' Request
req'
                   Request -> Manager -> IO (Response (IO ByteString))
HC.responseOpen Request
req' Manager
manager)
                (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return ()) forall a. Response a -> IO ()
HC.responseClose)
                forall a b. (a -> b) -> a -> b
$ \case
                    Left SomeException
e -> WaiProxySettings -> SomeException -> Application
wpsOnExc WaiProxySettings
wps SomeException
e Request
req Response -> IO ResponseReceived
sendResponse
                    Right Response (IO ByteString)
res -> do
                        let conduit :: ConduitT ByteString (Flush Builder) IO ()
conduit = forall a. a -> Maybe a -> a
fromMaybe
                                        (forall (m :: * -> *) i o r.
Monad m =>
(i -> ConduitT i o m r) -> ConduitT i o m ()
awaitForever (\ByteString
bs -> forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield (forall a. a -> Flush a
Chunk forall a b. (a -> b) -> a -> b
$ ByteString -> Builder
fromByteString ByteString
bs) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield forall a. Flush a
Flush))
                                        (WaiProxySettings
-> Request
-> Response ()
-> Maybe (ConduitT ByteString (Flush Builder) IO ())
wpsProcessBody WaiProxySettings
wps Request
req forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const () forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Response (IO ByteString)
res)
                            src :: ConduitT i ByteString IO ()
src = forall (m :: * -> *) i.
MonadIO m =>
IO ByteString -> ConduitT i ByteString m ()
bodyReaderSource forall a b. (a -> b) -> a -> b
$ forall body. Response body -> body
HC.responseBody Response (IO ByteString)
res
                            noChunked :: Bool
noChunked = HttpVersion -> Int
HT.httpMajor (Request -> HttpVersion
WAI.httpVersion Request
req) forall a. Ord a => a -> a -> Bool
>= Int
2 Bool -> Bool -> Bool
|| Request -> ByteString
WAI.requestMethod Request
req forall a. Eq a => a -> a -> Bool
== ByteString
HT.methodHead
                        Response -> IO ResponseReceived
sendResponse forall a b. (a -> b) -> a -> b
$ Status -> RequestHeaders -> StreamingBody -> Response
WAI.responseStream
                            (forall body. Response body -> Status
HC.responseStatus Response (IO ByteString)
res)
                            (forall a. (a -> Bool) -> [a] -> [a]
filter (\(HeaderName
key, ByteString
v) -> Bool -> Bool
not (HeaderName
key forall a. Ord a => a -> Set a -> Bool
`Set.member` Set HeaderName
strippedHeaders) Bool -> Bool -> Bool
||
                                                  HeaderName
key forall a. Eq a => a -> a -> Bool
== HeaderName
"content-length" Bool -> Bool -> Bool
&& (Bool
noChunked Bool -> Bool -> Bool
|| ByteString
v forall a. Eq a => a -> a -> Bool
== ByteString
"0"))
                                    (forall body. Response body -> RequestHeaders
HC.responseHeaders Response (IO ByteString)
res))
                            (\Builder -> IO ()
sendChunk IO ()
flush -> forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit forall a b. (a -> b) -> a -> b
$ forall {i}. ConduitT i ByteString IO ()
src forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT ByteString (Flush Builder) IO ()
conduit forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) a o.
Monad m =>
(a -> m ()) -> ConduitT a o m ()
CL.mapM_ (\Flush Builder
mb ->
                                case Flush Builder
mb of
                                    Flush Builder
Flush -> IO ()
flush
                                    Chunk Builder
b -> Builder -> IO ()
sendChunk Builder
b))

-- | Introduce a minor level of caching to handle some basic
-- retry cases inside http-client. But to avoid a DoS attack,
-- don't cache more than 65535 bytes (the theoretical max TCP packet size).
--
-- See: <https://github.com/fpco/http-reverse-proxy/issues/34#issuecomment-719136064>
semiCachedBody :: IO ByteString -> IO (HC.GivesPopper ())
semiCachedBody :: IO ByteString -> IO (GivesPopper ())
semiCachedBody IO ByteString
orig = do
  IORef SCB
ref <- forall a. a -> IO (IORef a)
newIORef forall a b. (a -> b) -> a -> b
$ Int -> [ByteString] -> SCB
SCBCaching Int
0 []
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ \NeedsPopper ()
needsPopper -> do
    let fromChunks :: Int -> [ByteString] -> SCB
fromChunks Int
len [ByteString]
chunks =
          case forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty (forall a. [a] -> [a]
reverse [ByteString]
chunks) of
            Maybe (NonEmpty ByteString)
Nothing -> Int -> [ByteString] -> SCB
SCBCaching Int
len [ByteString]
chunks
            Just NonEmpty ByteString
toDrain -> Int -> [ByteString] -> NonEmpty ByteString -> SCB
SCBDraining Int
len [ByteString]
chunks NonEmpty ByteString
toDrain
    SCB
state0 <- forall a. IORef a -> IO a
readIORef IORef SCB
ref forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
      \case
        SCBCaching Int
len [ByteString]
chunks -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Int -> [ByteString] -> SCB
fromChunks Int
len [ByteString]
chunks
        SCBDraining Int
len [ByteString]
chunks NonEmpty ByteString
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Int -> [ByteString] -> SCB
fromChunks Int
len [ByteString]
chunks
        SCB
SCBTooMuchData -> forall a. HasCallStack => String -> a
error String
"Cannot retry this request body, need to force a new request"
    forall a. IORef a -> a -> IO ()
writeIORef IORef SCB
ref forall a b. (a -> b) -> a -> b
$! SCB
state0
    let popper :: IO ByteString
        popper :: IO ByteString
popper = do
          forall a. IORef a -> IO a
readIORef IORef SCB
ref forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
            \case
              SCBDraining Int
len [ByteString]
chunks (ByteString
next:|[ByteString]
rest) -> do
                forall a. IORef a -> a -> IO ()
writeIORef IORef SCB
ref forall a b. (a -> b) -> a -> b
$!
                  case [ByteString]
rest of
                    [] -> Int -> [ByteString] -> SCB
SCBCaching Int
len [ByteString]
chunks
                    ByteString
x:[ByteString]
xs -> Int -> [ByteString] -> NonEmpty ByteString -> SCB
SCBDraining Int
len [ByteString]
chunks (ByteString
xforall a. a -> [a] -> NonEmpty a
:|[ByteString]
xs)
                forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
next
              SCB
SCBTooMuchData -> IO ByteString
orig
              SCBCaching Int
len [ByteString]
chunks -> do
                ByteString
bs <- IO ByteString
orig
                let newLen :: Int
newLen = Int
len forall a. Num a => a -> a -> a
+ ByteString -> Int
S.length ByteString
bs
                forall a. IORef a -> a -> IO ()
writeIORef IORef SCB
ref forall a b. (a -> b) -> a -> b
$!
                  if Int
newLen forall a. Ord a => a -> a -> Bool
> Int
maxCache
                    then SCB
SCBTooMuchData
                    else Int -> [ByteString] -> SCB
SCBCaching Int
newLen (ByteString
bsforall a. a -> [a] -> [a]
:[ByteString]
chunks)
                forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
bs

    NeedsPopper ()
needsPopper IO ByteString
popper
  where
    maxCache :: Int
maxCache = Int
65535

data SCB
  = SCBCaching !Int ![ByteString]
  | SCBDraining !Int ![ByteString] !(NonEmpty ByteString)
  | SCBTooMuchData

-- | 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 :: forall (m :: * -> *) o.
Monad m =>
ConduitT ByteString o m RequestHeaders
getHeaders =
    ByteString -> RequestHeaders
toHeaders forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {m :: * -> *} {o}.
Monad m =>
(ByteString -> ByteString) -> ConduitT ByteString o m ByteString
go forall a. a -> a
id
  where
    go :: (ByteString -> ByteString) -> ConduitT ByteString o m ByteString
go ByteString -> ByteString
front =
        forall (m :: * -> *) i o. Monad m => ConduitT i o m (Maybe i)
await forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall {o} {m :: * -> *}. ConduitT ByteString o m ByteString
close ByteString -> ConduitT ByteString o m ByteString
push
      where
        close :: ConduitT ByteString o m ByteString
close = forall i o (m :: * -> *). i -> ConduitT i o m ()
leftover ByteString
bs forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
bs
          where
            bs :: ByteString
bs = ByteString -> ByteString
front ByteString
S8.empty
        push :: ByteString -> ConduitT ByteString o m ByteString
push ByteString
bs'
            | ByteString
"\r\n\r\n" ByteString -> ByteString -> Bool
`S8.isInfixOf` ByteString
bs
              Bool -> Bool -> Bool
|| ByteString
"\n\n" ByteString -> ByteString -> Bool
`S8.isInfixOf` ByteString
bs
              Bool -> Bool -> Bool
|| ByteString -> Int
S8.length ByteString
bs forall a. Ord a => a -> a -> Bool
> Int
4096 = forall i o (m :: * -> *). i -> ConduitT i o m ()
leftover ByteString
bs forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
bs
            | Bool
otherwise = (ByteString -> ByteString) -> ConduitT ByteString o m ByteString
go forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => a -> a -> a
mappend ByteString
bs
          where
            bs :: ByteString
bs = ByteString -> ByteString
front ByteString
bs'
    toHeaders :: ByteString -> RequestHeaders
toHeaders = forall a b. (a -> b) -> [a] -> [b]
map ByteString -> (HeaderName, ByteString)
toHeader forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Bool
S8.null) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> [a] -> [a]
drop Int
1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
S8.lines
    toHeader :: ByteString -> (HeaderName, ByteString)
toHeader ByteString
bs =
        (forall s. FoldCase s => s -> CI s
CI.mk ByteString
key, ByteString
val)
      where
        (ByteString
key, ByteString
bs') = (Word8 -> Bool) -> ByteString -> (ByteString, ByteString)
S.break (forall a. Eq a => a -> a -> Bool
== Word8
_colon) ByteString
bs
        val :: ByteString
val = (Word8 -> Bool) -> ByteString -> ByteString
S.takeWhile (forall a. Eq a => a -> a -> Bool
/= Word8
_cr) forall a b. (a -> b) -> a -> b
$ (Word8 -> Bool) -> ByteString -> ByteString
S.dropWhile Word8 -> Bool
isSpace forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
S.drop Int
1 ByteString
bs'

{- 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 :: forall (m :: * -> *) i.
MonadIO m =>
IO ByteString -> ConduitT i ByteString m ()
bodyReaderSource IO ByteString
br =
    forall {i}. ConduitT i ByteString m ()
loop
  where
    loop :: ConduitT i ByteString m ()
loop = do
        ByteString
bs <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ IO ByteString -> IO ByteString
brRead IO ByteString
br
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Bool
S.null ByteString
bs) forall a b. (a -> b) -> a -> b
$ do
            forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield ByteString
bs
            ConduitT i ByteString m ()
loop