{-# LANGUAGE TemplateHaskell, OverloadedStrings, RecordWildCards #-}
{-# LANGUAGE TypeApplications, TupleSections, LambdaCase, NumDecimals #-}
module NgxExport.Tools.Subrequest (
makeSubrequest
,makeSubrequestWithRead
,registerCustomManager
,makeSubrequestFull
,makeSubrequestFullWithRead
,extractStatusFromFullResponse
,extractHeaderFromFullResponse
,extractBodyFromFullResponse
,extractExceptionFromFullResponse
,notForwardableResponseHeaders
,contentFromFullResponse
,makeBridgedSubrequest
,makeBridgedSubrequestWithRead
,makeBridgedSubrequestFull
,makeBridgedSubrequestFullWithRead
) where
import NgxExport
import NgxExport.Tools.Read
import NgxExport.Tools.Combinators
import NgxExport.Tools.SimpleService
import NgxExport.Tools.TimeInterval
import Network.HTTP.Client hiding (ResponseTimeout)
import qualified Network.HTTP.Client (HttpExceptionContent (ResponseTimeout))
import Network.HTTP.Client.TLS (newTlsManager)
import Network.HTTP.Client.BrReadWithTimeout
import Network.HTTP.Types
import qualified Network.Socket as S
import qualified Network.Socket.ByteString as SB
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as C8
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Lazy.Char8 as C8L
import Data.IORef
import qualified Data.Text.Encoding as T
import qualified Data.Text.Lazy.Encoding as TL
import qualified Data.Binary as Binary
import qualified Data.HashMap.Strict as HM
import Data.HashMap.Strict (HashMap)
import Data.HashSet (HashSet)
import qualified Data.HashSet as HS
import Data.CaseInsensitive hiding (map)
import Data.Function
import Data.Aeson
import Data.Maybe
import Data.List
import Control.Arrow
import Control.Exception
import System.IO.Unsafe
data SubrequestParseError = SubrequestParseError deriving Int -> SubrequestParseError -> ShowS
[SubrequestParseError] -> ShowS
SubrequestParseError -> String
(Int -> SubrequestParseError -> ShowS)
-> (SubrequestParseError -> String)
-> ([SubrequestParseError] -> ShowS)
-> Show SubrequestParseError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SubrequestParseError -> ShowS
showsPrec :: Int -> SubrequestParseError -> ShowS
$cshow :: SubrequestParseError -> String
show :: SubrequestParseError -> String
$cshowList :: [SubrequestParseError] -> ShowS
showList :: [SubrequestParseError] -> ShowS
Show
instance Exception SubrequestParseError
data BridgeParseError = BridgeParseError deriving Int -> BridgeParseError -> ShowS
[BridgeParseError] -> ShowS
BridgeParseError -> String
(Int -> BridgeParseError -> ShowS)
-> (BridgeParseError -> String)
-> ([BridgeParseError] -> ShowS)
-> Show BridgeParseError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BridgeParseError -> ShowS
showsPrec :: Int -> BridgeParseError -> ShowS
$cshow :: BridgeParseError -> String
show :: BridgeParseError -> String
$cshowList :: [BridgeParseError] -> ShowS
showList :: [BridgeParseError] -> ShowS
Show
instance Exception BridgeParseError
data UDSNotConfiguredError = UDSNotConfiguredError deriving Int -> UDSNotConfiguredError -> ShowS
[UDSNotConfiguredError] -> ShowS
UDSNotConfiguredError -> String
(Int -> UDSNotConfiguredError -> ShowS)
-> (UDSNotConfiguredError -> String)
-> ([UDSNotConfiguredError] -> ShowS)
-> Show UDSNotConfiguredError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> UDSNotConfiguredError -> ShowS
showsPrec :: Int -> UDSNotConfiguredError -> ShowS
$cshow :: UDSNotConfiguredError -> String
show :: UDSNotConfiguredError -> String
$cshowList :: [UDSNotConfiguredError] -> ShowS
showList :: [UDSNotConfiguredError] -> ShowS
Show
instance Exception UDSNotConfiguredError
newtype ManagerNotConfiguredError =
ManagerNotConfiguredError ByteString deriving Int -> ManagerNotConfiguredError -> ShowS
[ManagerNotConfiguredError] -> ShowS
ManagerNotConfiguredError -> String
(Int -> ManagerNotConfiguredError -> ShowS)
-> (ManagerNotConfiguredError -> String)
-> ([ManagerNotConfiguredError] -> ShowS)
-> Show ManagerNotConfiguredError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ManagerNotConfiguredError -> ShowS
showsPrec :: Int -> ManagerNotConfiguredError -> ShowS
$cshow :: ManagerNotConfiguredError -> String
show :: ManagerNotConfiguredError -> String
$cshowList :: [ManagerNotConfiguredError] -> ShowS
showList :: [ManagerNotConfiguredError] -> ShowS
Show
instance Exception ManagerNotConfiguredError
data ResponseTimeout = ResponseTimeoutDefault
| ResponseTimeout TimeInterval deriving (ResponseTimeout -> ResponseTimeout -> Bool
(ResponseTimeout -> ResponseTimeout -> Bool)
-> (ResponseTimeout -> ResponseTimeout -> Bool)
-> Eq ResponseTimeout
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ResponseTimeout -> ResponseTimeout -> Bool
== :: ResponseTimeout -> ResponseTimeout -> Bool
$c/= :: ResponseTimeout -> ResponseTimeout -> Bool
/= :: ResponseTimeout -> ResponseTimeout -> Bool
Eq, ReadPrec [ResponseTimeout]
ReadPrec ResponseTimeout
Int -> ReadS ResponseTimeout
ReadS [ResponseTimeout]
(Int -> ReadS ResponseTimeout)
-> ReadS [ResponseTimeout]
-> ReadPrec ResponseTimeout
-> ReadPrec [ResponseTimeout]
-> Read ResponseTimeout
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS ResponseTimeout
readsPrec :: Int -> ReadS ResponseTimeout
$creadList :: ReadS [ResponseTimeout]
readList :: ReadS [ResponseTimeout]
$creadPrec :: ReadPrec ResponseTimeout
readPrec :: ReadPrec ResponseTimeout
$creadListPrec :: ReadPrec [ResponseTimeout]
readListPrec :: ReadPrec [ResponseTimeout]
Read)
data ConnectionManager = Default
| UDS
| Custom ByteString deriving (ConnectionManager -> ConnectionManager -> Bool
(ConnectionManager -> ConnectionManager -> Bool)
-> (ConnectionManager -> ConnectionManager -> Bool)
-> Eq ConnectionManager
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ConnectionManager -> ConnectionManager -> Bool
== :: ConnectionManager -> ConnectionManager -> Bool
$c/= :: ConnectionManager -> ConnectionManager -> Bool
/= :: ConnectionManager -> ConnectionManager -> Bool
Eq, ReadPrec [ConnectionManager]
ReadPrec ConnectionManager
Int -> ReadS ConnectionManager
ReadS [ConnectionManager]
(Int -> ReadS ConnectionManager)
-> ReadS [ConnectionManager]
-> ReadPrec ConnectionManager
-> ReadPrec [ConnectionManager]
-> Read ConnectionManager
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS ConnectionManager
readsPrec :: Int -> ReadS ConnectionManager
$creadList :: ReadS [ConnectionManager]
readList :: ReadS [ConnectionManager]
$creadPrec :: ReadPrec ConnectionManager
readPrec :: ReadPrec ConnectionManager
$creadListPrec :: ReadPrec [ConnectionManager]
readListPrec :: ReadPrec [ConnectionManager]
Read)
data SubrequestConf =
SubrequestConf { SubrequestConf -> ByteString
srMethod :: ByteString
, SubrequestConf -> String
srUri :: String
, SubrequestConf -> ByteString
srBody :: L.ByteString
, :: RequestHeaders
, SubrequestConf -> ResponseTimeout
srResponseTimeout :: ResponseTimeout
, SubrequestConf -> ConnectionManager
srManager :: ConnectionManager
} deriving ReadPrec [SubrequestConf]
ReadPrec SubrequestConf
Int -> ReadS SubrequestConf
ReadS [SubrequestConf]
(Int -> ReadS SubrequestConf)
-> ReadS [SubrequestConf]
-> ReadPrec SubrequestConf
-> ReadPrec [SubrequestConf]
-> Read SubrequestConf
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS SubrequestConf
readsPrec :: Int -> ReadS SubrequestConf
$creadList :: ReadS [SubrequestConf]
readList :: ReadS [SubrequestConf]
$creadPrec :: ReadPrec SubrequestConf
readPrec :: ReadPrec SubrequestConf
$creadListPrec :: ReadPrec [SubrequestConf]
readListPrec :: ReadPrec [SubrequestConf]
Read
instance FromJSON SubrequestConf where
parseJSON :: Value -> Parser SubrequestConf
parseJSON = String
-> (Object -> Parser SubrequestConf)
-> Value
-> Parser SubrequestConf
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"SubrequestConf" ((Object -> Parser SubrequestConf)
-> Value -> Parser SubrequestConf)
-> (Object -> Parser SubrequestConf)
-> Value
-> Parser SubrequestConf
forall a b. (a -> b) -> a -> b
$ \Object
o -> do
ByteString
srMethod <- ByteString -> (Text -> ByteString) -> Maybe Text -> ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString
"" Text -> ByteString
T.encodeUtf8 (Maybe Text -> ByteString)
-> Parser (Maybe Text) -> Parser ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"method"
String
srUri <- Object
o Object -> Key -> Parser String
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"uri"
ByteString
srBody <- ByteString -> (Text -> ByteString) -> Maybe Text -> ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString
"" Text -> ByteString
TL.encodeUtf8 (Maybe Text -> ByteString)
-> Parser (Maybe Text) -> Parser ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"body"
RequestHeaders
srHeaders <- ((Text, Text) -> (HeaderName, ByteString))
-> [(Text, Text)] -> RequestHeaders
forall a b. (a -> b) -> [a] -> [b]
map (ByteString -> HeaderName
forall s. FoldCase s => s -> CI s
mk (ByteString -> HeaderName)
-> (Text -> ByteString) -> Text -> HeaderName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
T.encodeUtf8 (Text -> HeaderName)
-> (Text -> ByteString) -> (Text, Text) -> (HeaderName, ByteString)
forall b c b' c'. (b -> c) -> (b' -> c') -> (b, b') -> (c, c')
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** Text -> ByteString
T.encodeUtf8) ([(Text, Text)] -> RequestHeaders)
-> Parser [(Text, Text)] -> Parser RequestHeaders
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
Object
o Object -> Key -> Parser (Maybe [(Text, Text)])
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"headers" Parser (Maybe [(Text, Text)])
-> [(Text, Text)] -> Parser [(Text, Text)]
forall a. Parser (Maybe a) -> a -> Parser a
.!= []
ResponseTimeout
srResponseTimeout <- ResponseTimeout
-> (TimeInterval -> ResponseTimeout)
-> Maybe TimeInterval
-> ResponseTimeout
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ResponseTimeout
ResponseTimeoutDefault TimeInterval -> ResponseTimeout
ResponseTimeout (Maybe TimeInterval -> ResponseTimeout)
-> Parser (Maybe TimeInterval) -> Parser ResponseTimeout
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
Object
o Object -> Key -> Parser (Maybe TimeInterval)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"timeout"
ConnectionManager
srManager <- ConnectionManager
-> (Text -> ConnectionManager) -> Maybe Text -> ConnectionManager
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ConnectionManager
Default (\case
Text
"default" -> ConnectionManager
Default
Text
"uds" -> ConnectionManager
UDS
Text
v -> ByteString -> ConnectionManager
Custom (ByteString -> ConnectionManager)
-> ByteString -> ConnectionManager
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
T.encodeUtf8 Text
v
) (Maybe Text -> ConnectionManager)
-> Parser (Maybe Text) -> Parser ConnectionManager
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"manager"
SubrequestConf -> Parser SubrequestConf
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return SubrequestConf {String
RequestHeaders
ByteString
ByteString
ConnectionManager
ResponseTimeout
srMethod :: ByteString
srUri :: String
srBody :: ByteString
srHeaders :: RequestHeaders
srResponseTimeout :: ResponseTimeout
srManager :: ConnectionManager
srMethod :: ByteString
srUri :: String
srBody :: ByteString
srHeaders :: RequestHeaders
srResponseTimeout :: ResponseTimeout
srManager :: ConnectionManager
..}
data BridgeConf = BridgeConf { BridgeConf -> SubrequestConf
bridgeSource :: SubrequestConf
, BridgeConf -> SubrequestConf
bridgeSink :: SubrequestConf
} deriving ReadPrec [BridgeConf]
ReadPrec BridgeConf
Int -> ReadS BridgeConf
ReadS [BridgeConf]
(Int -> ReadS BridgeConf)
-> ReadS [BridgeConf]
-> ReadPrec BridgeConf
-> ReadPrec [BridgeConf]
-> Read BridgeConf
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS BridgeConf
readsPrec :: Int -> ReadS BridgeConf
$creadList :: ReadS [BridgeConf]
readList :: ReadS [BridgeConf]
$creadPrec :: ReadPrec BridgeConf
readPrec :: ReadPrec BridgeConf
$creadListPrec :: ReadPrec [BridgeConf]
readListPrec :: ReadPrec [BridgeConf]
Read
instance FromJSON BridgeConf where
parseJSON :: Value -> Parser BridgeConf
parseJSON = String
-> (Object -> Parser BridgeConf) -> Value -> Parser BridgeConf
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"BridgeConf" ((Object -> Parser BridgeConf) -> Value -> Parser BridgeConf)
-> (Object -> Parser BridgeConf) -> Value -> Parser BridgeConf
forall a b. (a -> b) -> a -> b
$ \Object
o -> do
SubrequestConf
bridgeSource <- Object
o Object -> Key -> Parser SubrequestConf
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"source"
SubrequestConf
bridgeSink <- Object
o Object -> Key -> Parser SubrequestConf
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"sink"
BridgeConf -> Parser BridgeConf
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return BridgeConf {SubrequestConf
bridgeSource :: SubrequestConf
bridgeSink :: SubrequestConf
bridgeSource :: SubrequestConf
bridgeSink :: SubrequestConf
..}
makeRequest :: SubrequestConf -> Request -> Request
makeRequest :: SubrequestConf -> Request -> Request
makeRequest SubrequestConf {String
RequestHeaders
ByteString
ByteString
ConnectionManager
ResponseTimeout
srMethod :: SubrequestConf -> ByteString
srUri :: SubrequestConf -> String
srBody :: SubrequestConf -> ByteString
srHeaders :: SubrequestConf -> RequestHeaders
srResponseTimeout :: SubrequestConf -> ResponseTimeout
srManager :: SubrequestConf -> ConnectionManager
srMethod :: ByteString
srUri :: String
srBody :: ByteString
srHeaders :: RequestHeaders
srResponseTimeout :: ResponseTimeout
srManager :: ConnectionManager
..} Request
req =
Request
req { method = if B.null srMethod
then method req
else srMethod
, requestBody = if L.null srBody
then requestBody req
else RequestBodyLBS srBody
, requestHeaders = unionBy ((==) `on` fst) srHeaders $
requestHeaders req
, responseTimeout = if srResponseTimeout == ResponseTimeoutDefault
then responseTimeout req
else setTimeout srResponseTimeout
}
where setTimeout :: ResponseTimeout -> ResponseTimeout
setTimeout (ResponseTimeout TimeInterval
v)
| Int
t Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = ResponseTimeout
responseTimeoutNone
| Bool
otherwise = Int -> ResponseTimeout
responseTimeoutMicro (Int -> ResponseTimeout) -> Int -> ResponseTimeout
forall a b. (a -> b) -> a -> b
$ Int
t Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1e6
where t :: Int
t = TimeInterval -> Int
toSec TimeInterval
v
setTimeout ResponseTimeout
_ = ResponseTimeout
forall a. HasCallStack => a
undefined
subrequest :: (String -> IO Request) ->
(Response L.ByteString -> L.ByteString) -> SubrequestConf ->
IO L.ByteString
subrequest :: (String -> IO Request)
-> (Response ByteString -> ByteString)
-> SubrequestConf
-> IO ByteString
subrequest String -> IO Request
parseRequestF Response ByteString -> ByteString
buildResponseF sub :: SubrequestConf
sub@SubrequestConf {String
RequestHeaders
ByteString
ByteString
ConnectionManager
ResponseTimeout
srMethod :: SubrequestConf -> ByteString
srUri :: SubrequestConf -> String
srBody :: SubrequestConf -> ByteString
srHeaders :: SubrequestConf -> RequestHeaders
srResponseTimeout :: SubrequestConf -> ResponseTimeout
srManager :: SubrequestConf -> ConnectionManager
srMethod :: ByteString
srUri :: String
srBody :: ByteString
srHeaders :: RequestHeaders
srResponseTimeout :: ResponseTimeout
srManager :: ConnectionManager
..} = do
Manager
man <- SubrequestConf -> IO Manager
getManager SubrequestConf
sub
Request
req <- String -> IO Request
parseRequestF String
srUri
Response ByteString -> ByteString
buildResponseF (Response ByteString -> ByteString)
-> IO (Response ByteString) -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Request -> Manager -> IO (Response ByteString)
httpLbsBrReadWithTimeout (SubrequestConf -> Request -> Request
makeRequest SubrequestConf
sub Request
req) Manager
man
subrequestBody :: SubrequestConf -> IO L.ByteString
subrequestBody :: SubrequestConf -> IO ByteString
subrequestBody = (String -> IO Request)
-> (Response ByteString -> ByteString)
-> SubrequestConf
-> IO ByteString
subrequest String -> IO Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseUrlThrow Response ByteString -> ByteString
forall body. Response body -> body
responseBody
type FullResponse = (Int, [(ByteString, ByteString)], L.ByteString, ByteString)
handleFullResponse :: IO L.ByteString -> IO L.ByteString
handleFullResponse :: IO ByteString -> IO ByteString
handleFullResponse = (SomeException -> IO ByteString) -> IO ByteString -> IO ByteString
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle ((SomeException -> IO ByteString)
-> IO ByteString -> IO ByteString)
-> (SomeException -> IO ByteString)
-> IO ByteString
-> IO ByteString
forall a b. (a -> b) -> a -> b
$ \SomeException
e -> do
let msg :: ByteString
msg = String -> ByteString
C8.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ SomeException -> String
forall a. Show a => a -> String
show SomeException
e
responseXXX :: t -> (t, [a], ByteString, ByteString)
responseXXX = (, [], ByteString
"", ByteString
msg)
response500 :: (Int, [a], ByteString, ByteString)
response500 = Int -> (Int, [a], ByteString, ByteString)
forall {t} {a}. t -> (t, [a], ByteString, ByteString)
responseXXX Int
500
response502 :: (Int, [a], ByteString, ByteString)
response502 = Int -> (Int, [a], ByteString, ByteString)
forall {t} {a}. t -> (t, [a], ByteString, ByteString)
responseXXX Int
502
ByteString -> IO ByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ forall a. Binary a => a -> ByteString
Binary.encode @FullResponse (FullResponse -> ByteString) -> FullResponse -> ByteString
forall a b. (a -> b) -> a -> b
$
case SomeException -> Maybe HttpException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e of
Just (HttpExceptionRequest Request
_ HttpExceptionContent
c) ->
case HttpExceptionContent
c of
HttpExceptionContent
Network.HTTP.Client.ResponseTimeout -> FullResponse
forall {a}. (Int, [a], ByteString, ByteString)
response502
HttpExceptionContent
ConnectionTimeout -> FullResponse
forall {a}. (Int, [a], ByteString, ByteString)
response502
ConnectionFailure SomeException
_ -> FullResponse
forall {a}. (Int, [a], ByteString, ByteString)
response502
StatusCodeException Response ()
r ByteString
_ ->
let status :: Int
status = Status -> Int
statusCode (Status -> Int) -> Status -> Int
forall a b. (a -> b) -> a -> b
$ Response () -> Status
forall body. Response body -> Status
responseStatus Response ()
r
in Int -> FullResponse
forall {t} {a}. t -> (t, [a], ByteString, ByteString)
responseXXX Int
status
HttpExceptionContent
_ -> FullResponse
forall {a}. (Int, [a], ByteString, ByteString)
response500
Maybe HttpException
_ -> FullResponse
forall {a}. (Int, [a], ByteString, ByteString)
response500
buildFullResponse :: Response L.ByteString -> L.ByteString
buildFullResponse :: Response ByteString -> ByteString
buildFullResponse Response ByteString
r =
let status :: Int
status = Status -> Int
statusCode (Status -> Int) -> Status -> Int
forall a b. (a -> b) -> a -> b
$ Response ByteString -> Status
forall body. Response body -> Status
responseStatus Response ByteString
r
headers :: [(ByteString, ByteString)]
headers = ((HeaderName, ByteString) -> (ByteString, ByteString))
-> RequestHeaders -> [(ByteString, ByteString)]
forall a b. (a -> b) -> [a] -> [b]
map ((HeaderName -> ByteString)
-> (HeaderName, ByteString) -> (ByteString, ByteString)
forall b c d. (b -> c) -> (b, d) -> (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first HeaderName -> ByteString
forall s. CI s -> s
original) (RequestHeaders -> [(ByteString, ByteString)])
-> RequestHeaders -> [(ByteString, ByteString)]
forall a b. (a -> b) -> a -> b
$ Response ByteString -> RequestHeaders
forall body. Response body -> RequestHeaders
responseHeaders Response ByteString
r
body :: ByteString
body = Response ByteString -> ByteString
forall body. Response body -> body
responseBody Response ByteString
r
in forall a. Binary a => a -> ByteString
Binary.encode @FullResponse (Int
status, [(ByteString, ByteString)]
headers, ByteString
body, ByteString
"")
subrequestFull :: SubrequestConf -> IO L.ByteString
subrequestFull :: SubrequestConf -> IO ByteString
subrequestFull = IO ByteString -> IO ByteString
handleFullResponse (IO ByteString -> IO ByteString)
-> (SubrequestConf -> IO ByteString)
-> SubrequestConf
-> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> IO Request)
-> (Response ByteString -> ByteString)
-> SubrequestConf
-> IO ByteString
subrequest String -> IO Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseRequest Response ByteString -> ByteString
buildFullResponse
httpManager :: Manager
httpManager :: Manager
httpManager = IO Manager -> Manager
forall a. IO a -> a
unsafePerformIO IO Manager
forall (m :: * -> *). MonadIO m => m Manager
newTlsManager
{-# NOINLINE httpManager #-}
httpUDSManager :: IORef (Maybe Manager)
httpUDSManager :: IORef (Maybe Manager)
httpUDSManager = IO (IORef (Maybe Manager)) -> IORef (Maybe Manager)
forall a. IO a -> a
unsafePerformIO (IO (IORef (Maybe Manager)) -> IORef (Maybe Manager))
-> IO (IORef (Maybe Manager)) -> IORef (Maybe Manager)
forall a b. (a -> b) -> a -> b
$ Maybe Manager -> IO (IORef (Maybe Manager))
forall a. a -> IO (IORef a)
newIORef Maybe Manager
forall a. Maybe a
Nothing
{-# NOINLINE httpUDSManager #-}
httpCustomManager :: IORef (HashMap ByteString Manager)
httpCustomManager :: IORef (HashMap ByteString Manager)
httpCustomManager = IO (IORef (HashMap ByteString Manager))
-> IORef (HashMap ByteString Manager)
forall a. IO a -> a
unsafePerformIO (IO (IORef (HashMap ByteString Manager))
-> IORef (HashMap ByteString Manager))
-> IO (IORef (HashMap ByteString Manager))
-> IORef (HashMap ByteString Manager)
forall a b. (a -> b) -> a -> b
$ HashMap ByteString Manager
-> IO (IORef (HashMap ByteString Manager))
forall a. a -> IO (IORef a)
newIORef HashMap ByteString Manager
forall k v. HashMap k v
HM.empty
{-# NOINLINE httpCustomManager #-}
getManager :: SubrequestConf -> IO Manager
getManager :: SubrequestConf -> IO Manager
getManager SubrequestConf {String
RequestHeaders
ByteString
ByteString
ConnectionManager
ResponseTimeout
srMethod :: SubrequestConf -> ByteString
srUri :: SubrequestConf -> String
srBody :: SubrequestConf -> ByteString
srHeaders :: SubrequestConf -> RequestHeaders
srResponseTimeout :: SubrequestConf -> ResponseTimeout
srManager :: SubrequestConf -> ConnectionManager
srMethod :: ByteString
srUri :: String
srBody :: ByteString
srHeaders :: RequestHeaders
srResponseTimeout :: ResponseTimeout
srManager :: ConnectionManager
..} =
case ConnectionManager
srManager of
ConnectionManager
Default ->
Manager -> IO Manager
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Manager
httpManager
ConnectionManager
UDS ->
Manager -> Maybe Manager -> Manager
forall a. a -> Maybe a -> a
fromMaybe (UDSNotConfiguredError -> Manager
forall a e. Exception e => e -> a
throw UDSNotConfiguredError
UDSNotConfiguredError) (Maybe Manager -> Manager) -> IO (Maybe Manager) -> IO Manager
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
IORef (Maybe Manager) -> IO (Maybe Manager)
forall a. IORef a -> IO a
readIORef IORef (Maybe Manager)
httpUDSManager
Custom ByteString
k ->
Manager -> Maybe Manager -> Manager
forall a. a -> Maybe a -> a
fromMaybe (ManagerNotConfiguredError -> Manager
forall a e. Exception e => e -> a
throw (ManagerNotConfiguredError -> Manager)
-> ManagerNotConfiguredError -> Manager
forall a b. (a -> b) -> a -> b
$ ByteString -> ManagerNotConfiguredError
ManagerNotConfiguredError ByteString
k) (Maybe Manager -> Manager)
-> (HashMap ByteString Manager -> Maybe Manager)
-> HashMap ByteString Manager
-> Manager
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> HashMap ByteString Manager -> Maybe Manager
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup ByteString
k (HashMap ByteString Manager -> Manager)
-> IO (HashMap ByteString Manager) -> IO Manager
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
IORef (HashMap ByteString Manager)
-> IO (HashMap ByteString Manager)
forall a. IORef a -> IO a
readIORef IORef (HashMap ByteString Manager)
httpCustomManager
makeSubrequest
:: ByteString
-> IO L.ByteString
makeSubrequest :: ByteString -> IO ByteString
makeSubrequest =
IO ByteString
-> (SubrequestConf -> IO ByteString)
-> Maybe SubrequestConf
-> IO ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (SubrequestParseError -> IO ByteString
forall e a. Exception e => e -> IO a
throwIO SubrequestParseError
SubrequestParseError) SubrequestConf -> IO ByteString
subrequestBody (Maybe SubrequestConf -> IO ByteString)
-> (ByteString -> Maybe SubrequestConf)
-> ByteString
-> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall a. FromJSON a => ByteString -> Maybe a
readFromByteStringAsJSON @SubrequestConf
ngxExportAsyncIOYY 'makeSubrequest
makeSubrequestWithRead
:: ByteString
-> IO L.ByteString
makeSubrequestWithRead :: ByteString -> IO ByteString
makeSubrequestWithRead =
IO ByteString
-> (SubrequestConf -> IO ByteString)
-> Maybe SubrequestConf
-> IO ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (SubrequestParseError -> IO ByteString
forall e a. Exception e => e -> IO a
throwIO SubrequestParseError
SubrequestParseError) SubrequestConf -> IO ByteString
subrequestBody (Maybe SubrequestConf -> IO ByteString)
-> (ByteString -> Maybe SubrequestConf)
-> ByteString
-> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall a. Read a => ByteString -> Maybe a
readFromByteString @SubrequestConf
ngxExportAsyncIOYY 'makeSubrequestWithRead
newtype UDSConf = UDSConf { UDSConf -> String
udsPath :: FilePath } deriving ReadPrec [UDSConf]
ReadPrec UDSConf
Int -> ReadS UDSConf
ReadS [UDSConf]
(Int -> ReadS UDSConf)
-> ReadS [UDSConf]
-> ReadPrec UDSConf
-> ReadPrec [UDSConf]
-> Read UDSConf
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS UDSConf
readsPrec :: Int -> ReadS UDSConf
$creadList :: ReadS [UDSConf]
readList :: ReadS [UDSConf]
$creadPrec :: ReadPrec UDSConf
readPrec :: ReadPrec UDSConf
$creadListPrec :: ReadPrec [UDSConf]
readListPrec :: ReadPrec [UDSConf]
Read
configureUDS :: UDSConf -> NgxExportService
configureUDS :: UDSConf -> Bool -> IO ByteString
configureUDS = (UDSConf -> IO ByteString) -> UDSConf -> Bool -> IO ByteString
forall a. (a -> IO ByteString) -> a -> Bool -> IO ByteString
ignitionService ((UDSConf -> IO ByteString) -> UDSConf -> Bool -> IO ByteString)
-> (UDSConf -> IO ByteString) -> UDSConf -> Bool -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \UDSConf {String
udsPath :: UDSConf -> String
udsPath :: String
..} -> IO () -> IO ByteString
forall a. IO a -> IO ByteString
voidHandler (IO () -> IO ByteString) -> IO () -> IO ByteString
forall a b. (a -> b) -> a -> b
$ do
Manager
man <- ManagerSettings -> IO Manager
newManager ManagerSettings
defaultManagerSettings
{ managerRawConnection = return $ openUDS udsPath }
IORef (Maybe Manager) -> Maybe Manager -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe Manager)
httpUDSManager (Maybe Manager -> IO ()) -> Maybe Manager -> IO ()
forall a b. (a -> b) -> a -> b
$ Manager -> Maybe Manager
forall a. a -> Maybe a
Just Manager
man
where openUDS :: String -> p -> p -> p -> IO Connection
openUDS String
path p
_ p
_ p
_ = do
Socket
s <- Family -> SocketType -> CInt -> IO Socket
S.socket Family
S.AF_UNIX SocketType
S.Stream CInt
S.defaultProtocol
Socket -> SockAddr -> IO ()
S.connect Socket
s (String -> SockAddr
S.SockAddrUnix String
path)
IO ByteString -> (ByteString -> IO ()) -> IO () -> IO Connection
makeConnection (Socket -> Int -> IO ByteString
SB.recv Socket
s Int
4096) (Socket -> ByteString -> IO ()
SB.sendAll Socket
s) (Socket -> IO ()
S.close Socket
s)
ngxExportSimpleServiceTyped 'configureUDS ''UDSConf SingleShotService
registerCustomManager
:: ByteString
-> Manager
-> IO ()
registerCustomManager :: ByteString -> Manager -> IO ()
registerCustomManager = (IORef (HashMap ByteString Manager)
-> (HashMap ByteString Manager -> HashMap ByteString Manager)
-> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef (HashMap ByteString Manager)
httpCustomManager ((HashMap ByteString Manager -> HashMap ByteString Manager)
-> IO ())
-> (Manager
-> HashMap ByteString Manager -> HashMap ByteString Manager)
-> Manager
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) ((Manager
-> HashMap ByteString Manager -> HashMap ByteString Manager)
-> Manager -> IO ())
-> (ByteString
-> Manager
-> HashMap ByteString Manager
-> HashMap ByteString Manager)
-> ByteString
-> Manager
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString
-> Manager
-> HashMap ByteString Manager
-> HashMap ByteString Manager
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert
makeSubrequestFull
:: ByteString
-> IO L.ByteString
makeSubrequestFull :: ByteString -> IO ByteString
makeSubrequestFull =
IO ByteString
-> (SubrequestConf -> IO ByteString)
-> Maybe SubrequestConf
-> IO ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (ByteString -> IO ByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$
forall a. Binary a => a -> ByteString
Binary.encode @FullResponse
(Int
400, [], ByteString
"", ByteString
"Unreadable subrequest data")
) SubrequestConf -> IO ByteString
subrequestFull (Maybe SubrequestConf -> IO ByteString)
-> (ByteString -> Maybe SubrequestConf)
-> ByteString
-> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. FromJSON a => ByteString -> Maybe a
readFromByteStringAsJSON @SubrequestConf
ngxExportAsyncIOYY 'makeSubrequestFull
makeSubrequestFullWithRead
:: ByteString
-> IO L.ByteString
makeSubrequestFullWithRead :: ByteString -> IO ByteString
makeSubrequestFullWithRead =
IO ByteString
-> (SubrequestConf -> IO ByteString)
-> Maybe SubrequestConf
-> IO ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (ByteString -> IO ByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$
forall a. Binary a => a -> ByteString
Binary.encode @FullResponse
(Int
400, [], ByteString
"", ByteString
"Unreadable subrequest data")
) SubrequestConf -> IO ByteString
subrequestFull (Maybe SubrequestConf -> IO ByteString)
-> (ByteString -> Maybe SubrequestConf)
-> ByteString
-> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Read a => ByteString -> Maybe a
readFromByteString @SubrequestConf
ngxExportAsyncIOYY 'makeSubrequestFullWithRead
extractStatusFromFullResponse
:: ByteString
-> L.ByteString
= String -> ByteString
C8L.pack (String -> ByteString)
-> (ByteString -> String) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show (Int -> String) -> (ByteString -> Int) -> ByteString -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
(\(Int
a, [(ByteString, ByteString)]
_, ByteString
_, ByteString
_) -> Int
a) (FullResponse -> Int)
-> (ByteString -> FullResponse) -> ByteString -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Binary a => ByteString -> a
Binary.decode @FullResponse (ByteString -> FullResponse)
-> (ByteString -> ByteString) -> ByteString -> FullResponse
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
L.fromStrict
extractHeaderFromFullResponse
:: ByteString
-> L.ByteString
ByteString
v =
let (HeaderName
h, ByteString
b) = ByteString -> HeaderName
forall s. FoldCase s => s -> CI s
mk (ByteString -> HeaderName)
-> (ByteString -> ByteString)
-> (ByteString, ByteString)
-> (HeaderName, ByteString)
forall b c b' c'. (b -> c) -> (b' -> c') -> (b, b') -> (c, c')
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** HasCallStack => ByteString -> ByteString
ByteString -> ByteString
C8.tail ((ByteString, ByteString) -> (HeaderName, ByteString))
-> (ByteString, ByteString) -> (HeaderName, ByteString)
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> ByteString -> (ByteString, ByteString)
C8.break (Char
'|' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==) ByteString
v
(Int
_, [(ByteString, ByteString)]
hs, ByteString
_, ByteString
_) = forall a. Binary a => ByteString -> a
Binary.decode @FullResponse (ByteString -> FullResponse) -> ByteString -> FullResponse
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
L.fromStrict ByteString
b
in ByteString
-> (ByteString -> ByteString) -> Maybe ByteString -> ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString
"" ByteString -> ByteString
L.fromStrict (Maybe ByteString -> ByteString) -> Maybe ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ HeaderName -> RequestHeaders -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
h (RequestHeaders -> Maybe ByteString)
-> RequestHeaders -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ ((ByteString, ByteString) -> (HeaderName, ByteString))
-> [(ByteString, ByteString)] -> RequestHeaders
forall a b. (a -> b) -> [a] -> [b]
map ((ByteString -> HeaderName)
-> (ByteString, ByteString) -> (HeaderName, ByteString)
forall b c d. (b -> c) -> (b, d) -> (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ByteString -> HeaderName
forall s. FoldCase s => s -> CI s
mk) [(ByteString, ByteString)]
hs
extractBodyFromFullResponse
:: ByteString
-> L.ByteString
extractBodyFromFullResponse :: ByteString -> ByteString
extractBodyFromFullResponse =
(\(Int
_, [(ByteString, ByteString)]
_, ByteString
a, ByteString
_) -> ByteString
a) (FullResponse -> ByteString)
-> (ByteString -> FullResponse) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Binary a => ByteString -> a
Binary.decode @FullResponse (ByteString -> FullResponse)
-> (ByteString -> ByteString) -> ByteString -> FullResponse
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
L.fromStrict
ngxExportYY 'extractBodyFromFullResponse
extractExceptionFromFullResponse
:: ByteString
-> L.ByteString
= ByteString -> ByteString
L.fromStrict (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
(\(Int
_, [(ByteString, ByteString)]
_, ByteString
_, ByteString
a) -> ByteString
a) (FullResponse -> ByteString)
-> (ByteString -> FullResponse) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Binary a => ByteString -> a
Binary.decode @FullResponse (ByteString -> FullResponse)
-> (ByteString -> ByteString) -> ByteString -> FullResponse
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
L.fromStrict
notForwardableResponseHeaders :: HashSet HeaderName
= [HeaderName] -> HashSet HeaderName
forall a. (Eq a, Hashable a) => [a] -> HashSet a
HS.fromList ([HeaderName] -> HashSet HeaderName)
-> [HeaderName] -> HashSet HeaderName
forall a b. (a -> b) -> a -> b
$
(ByteString -> HeaderName) -> [ByteString] -> [HeaderName]
forall a b. (a -> b) -> [a] -> [b]
map ByteString -> HeaderName
forall s. FoldCase s => s -> CI s
mk [ByteString
"Connection"
,ByteString
"Content-Length"
,ByteString
"Content-Type"
,ByteString
"Date"
,ByteString
"Keep-Alive"
,ByteString
"Last-Modified"
,ByteString
"Server"
,ByteString
"Transfer-Encoding"
,ByteString
"X-Pad"
]
deleteHeaders :: HashSet HeaderName -> Bool -> ResponseHeaders ->
ResponseHeaders
HashSet HeaderName
headersToDelete Bool
deleteXAccel =
((HeaderName, ByteString) -> Bool)
-> RequestHeaders -> RequestHeaders
forall a. (a -> Bool) -> [a] -> [a]
filter (\(HeaderName
n, ByteString
_) -> Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$
HeaderName
n HeaderName -> HashSet HeaderName -> Bool
forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
`HS.member` HashSet HeaderName
headersToDelete Bool -> Bool -> Bool
||
Bool
deleteXAccel Bool -> Bool -> Bool
&&
ByteString -> ByteString
forall s. FoldCase s => s -> s
foldCase ByteString
"X-Accel-" ByteString -> ByteString -> Bool
`B.isPrefixOf` HeaderName -> ByteString
forall s. CI s -> s
foldedCase HeaderName
n
)
contentFromFullResponse
:: HashSet HeaderName
-> Bool
-> (L.ByteString -> ByteString -> L.ByteString)
-> ByteString
-> ContentHandlerResult
contentFromFullResponse :: HashSet HeaderName
-> Bool
-> (ByteString -> ByteString -> ByteString)
-> ByteString
-> ContentHandlerResult
contentFromFullResponse HashSet HeaderName
headersToDelete Bool
deleteXAccel ByteString -> ByteString -> ByteString
f ByteString
v =
let (Int
st, [(ByteString, ByteString)]
hs, ByteString
b, ByteString
e) = forall a. Binary a => ByteString -> a
Binary.decode @FullResponse (ByteString -> FullResponse) -> ByteString -> FullResponse
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
L.fromStrict ByteString
v
hs' :: RequestHeaders
hs' = ((ByteString, ByteString) -> (HeaderName, ByteString))
-> [(ByteString, ByteString)] -> RequestHeaders
forall a b. (a -> b) -> [a] -> [b]
map ((ByteString -> HeaderName)
-> (ByteString, ByteString) -> (HeaderName, ByteString)
forall b c d. (b -> c) -> (b, d) -> (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ByteString -> HeaderName
forall s. FoldCase s => s -> CI s
mk) [(ByteString, ByteString)]
hs
ct :: ByteString
ct = ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
"" (Maybe ByteString -> ByteString) -> Maybe ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ HeaderName -> RequestHeaders -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (ByteString -> HeaderName
forall s. FoldCase s => s -> CI s
mk ByteString
"Content-Type") RequestHeaders
hs'
hs'' :: RequestHeaders
hs'' = HashSet HeaderName -> Bool -> RequestHeaders -> RequestHeaders
deleteHeaders HashSet HeaderName
headersToDelete Bool
deleteXAccel RequestHeaders
hs'
in (ByteString -> ByteString -> ByteString
f ByteString
b ByteString
e, ByteString
ct, Int
st, ((HeaderName, ByteString) -> (ByteString, ByteString))
-> RequestHeaders -> [(ByteString, ByteString)]
forall a b. (a -> b) -> [a] -> [b]
map ((HeaderName -> ByteString)
-> (HeaderName, ByteString) -> (ByteString, ByteString)
forall b c d. (b -> c) -> (b, d) -> (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first HeaderName -> ByteString
forall s. CI s -> s
original) RequestHeaders
hs'')
fromFullResponse :: ByteString -> ContentHandlerResult
fromFullResponse :: ByteString -> ContentHandlerResult
fromFullResponse =
HashSet HeaderName
-> Bool
-> (ByteString -> ByteString -> ByteString)
-> ByteString
-> ContentHandlerResult
contentFromFullResponse HashSet HeaderName
notForwardableResponseHeaders Bool
True ByteString -> ByteString -> ByteString
forall a b. a -> b -> a
const
ngxExportHandler 'fromFullResponse
fromFullResponseWithException :: ByteString -> ContentHandlerResult
fromFullResponseWithException :: ByteString -> ContentHandlerResult
fromFullResponseWithException =
HashSet HeaderName
-> Bool
-> (ByteString -> ByteString -> ByteString)
-> ByteString
-> ContentHandlerResult
contentFromFullResponse HashSet HeaderName
notForwardableResponseHeaders Bool
True ByteString -> ByteString -> ByteString
f
where f :: ByteString -> ByteString -> ByteString
f ByteString
"" = ByteString -> ByteString
L.fromStrict
f ByteString
b = ByteString -> ByteString -> ByteString
forall a b. a -> b -> a
const ByteString
b
ngxExportHandler 'fromFullResponseWithException
makeStreamingRequest :: GivesPopper () -> SubrequestConf -> Request -> Request
makeStreamingRequest :: GivesPopper () -> SubrequestConf -> Request -> Request
makeStreamingRequest GivesPopper ()
givesPopper SubrequestConf
conf Request
req =
SubrequestConf -> Request -> Request
makeRequest SubrequestConf
conf { srMethod = "POST" , srBody = "" }
Request
req { requestBody = RequestBodyStreamChunked givesPopper }
bridgedSubrequest :: (String -> IO Request) ->
(Response L.ByteString -> L.ByteString) -> BridgeConf ->
IO L.ByteString
bridgedSubrequest :: (String -> IO Request)
-> (Response ByteString -> ByteString)
-> BridgeConf
-> IO ByteString
bridgedSubrequest String -> IO Request
parseRequestF Response ByteString -> ByteString
buildResponseF BridgeConf {SubrequestConf
bridgeSource :: BridgeConf -> SubrequestConf
bridgeSink :: BridgeConf -> SubrequestConf
bridgeSource :: SubrequestConf
bridgeSink :: SubrequestConf
..} = do
Manager
manIn <- SubrequestConf -> IO Manager
getManager SubrequestConf
bridgeSource
Manager
manOut <- SubrequestConf -> IO Manager
getManager SubrequestConf
bridgeSink
Request
reqIn <- String -> IO Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseUrlThrow (String -> IO Request) -> String -> IO Request
forall a b. (a -> b) -> a -> b
$ SubrequestConf -> String
srUri SubrequestConf
bridgeSource
Request
reqOut <- String -> IO Request
parseRequestF (String -> IO Request) -> String -> IO Request
forall a b. (a -> b) -> a -> b
$ SubrequestConf -> String
srUri SubrequestConf
bridgeSink
Request
-> Manager
-> (Response (IO ByteString) -> IO ByteString)
-> IO ByteString
forall a.
Request -> Manager -> (Response (IO ByteString) -> IO a) -> IO a
withResponse (SubrequestConf -> Request -> Request
makeRequest SubrequestConf
bridgeSource Request
reqIn) Manager
manIn ((Response (IO ByteString) -> IO ByteString) -> IO ByteString)
-> (Response (IO ByteString) -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \Response (IO ByteString)
respIn -> do
let reqOut' :: Request
reqOut' = Request
reqOut { requestHeaders =
deleteHeaders
notForwardableResponseHeaders
True (responseHeaders respIn)
}
tmo :: Int
tmo = Request -> Manager -> Int
fromResponseTimeout Request
reqIn Manager
manIn
givesPopper :: (IO ByteString -> b) -> b
givesPopper IO ByteString -> b
needsPopper = IO ByteString -> b
needsPopper (IO ByteString -> b) -> IO ByteString -> b
forall a b. (a -> b) -> a -> b
$
Int -> Request -> IO ByteString -> IO ByteString
brReadWithTimeout Int
tmo Request
reqIn (IO ByteString -> IO ByteString) -> IO ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ Response (IO ByteString) -> IO ByteString
forall body. Response body -> body
responseBody Response (IO ByteString)
respIn
Response ByteString -> ByteString
buildResponseF (Response ByteString -> ByteString)
-> IO (Response ByteString) -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
Request -> Manager -> IO (Response ByteString)
httpLbsBrReadWithTimeout
(GivesPopper () -> SubrequestConf -> Request -> Request
makeStreamingRequest GivesPopper ()
forall {b}. (IO ByteString -> b) -> b
givesPopper SubrequestConf
bridgeSink Request
reqOut') Manager
manOut
bridgedSubrequestBody :: BridgeConf -> IO L.ByteString
bridgedSubrequestBody :: BridgeConf -> IO ByteString
bridgedSubrequestBody = (String -> IO Request)
-> (Response ByteString -> ByteString)
-> BridgeConf
-> IO ByteString
bridgedSubrequest String -> IO Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseUrlThrow Response ByteString -> ByteString
forall body. Response body -> body
responseBody
bridgedSubrequestFull :: BridgeConf -> IO L.ByteString
bridgedSubrequestFull :: BridgeConf -> IO ByteString
bridgedSubrequestFull =
IO ByteString -> IO ByteString
handleFullResponse (IO ByteString -> IO ByteString)
-> (BridgeConf -> IO ByteString) -> BridgeConf -> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> IO Request)
-> (Response ByteString -> ByteString)
-> BridgeConf
-> IO ByteString
bridgedSubrequest String -> IO Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseRequest Response ByteString -> ByteString
buildFullResponse
makeBridgedSubrequest
:: ByteString
-> IO L.ByteString
makeBridgedSubrequest :: ByteString -> IO ByteString
makeBridgedSubrequest =
IO ByteString
-> (BridgeConf -> IO ByteString)
-> Maybe BridgeConf
-> IO ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (BridgeParseError -> IO ByteString
forall e a. Exception e => e -> IO a
throwIO BridgeParseError
BridgeParseError) BridgeConf -> IO ByteString
bridgedSubrequestBody (Maybe BridgeConf -> IO ByteString)
-> (ByteString -> Maybe BridgeConf) -> ByteString -> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall a. FromJSON a => ByteString -> Maybe a
readFromByteStringAsJSON @BridgeConf
ngxExportAsyncIOYY 'makeBridgedSubrequest
makeBridgedSubrequestWithRead
:: ByteString
-> IO L.ByteString
makeBridgedSubrequestWithRead :: ByteString -> IO ByteString
makeBridgedSubrequestWithRead =
IO ByteString
-> (BridgeConf -> IO ByteString)
-> Maybe BridgeConf
-> IO ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (BridgeParseError -> IO ByteString
forall e a. Exception e => e -> IO a
throwIO BridgeParseError
BridgeParseError) BridgeConf -> IO ByteString
bridgedSubrequestBody (Maybe BridgeConf -> IO ByteString)
-> (ByteString -> Maybe BridgeConf) -> ByteString -> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall a. Read a => ByteString -> Maybe a
readFromByteString @BridgeConf
ngxExportAsyncIOYY 'makeBridgedSubrequestWithRead
makeBridgedSubrequestFull
:: ByteString
-> IO L.ByteString
makeBridgedSubrequestFull :: ByteString -> IO ByteString
makeBridgedSubrequestFull =
IO ByteString
-> (BridgeConf -> IO ByteString)
-> Maybe BridgeConf
-> IO ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (ByteString -> IO ByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$
forall a. Binary a => a -> ByteString
Binary.encode @FullResponse
(Int
400, [], ByteString
"", ByteString
"Unreadable bridged subrequest data")
) BridgeConf -> IO ByteString
bridgedSubrequestFull (Maybe BridgeConf -> IO ByteString)
-> (ByteString -> Maybe BridgeConf) -> ByteString -> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. FromJSON a => ByteString -> Maybe a
readFromByteStringAsJSON @BridgeConf
ngxExportAsyncIOYY 'makeBridgedSubrequestFull
makeBridgedSubrequestFullWithRead
:: ByteString
-> IO L.ByteString
makeBridgedSubrequestFullWithRead :: ByteString -> IO ByteString
makeBridgedSubrequestFullWithRead =
IO ByteString
-> (BridgeConf -> IO ByteString)
-> Maybe BridgeConf
-> IO ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (ByteString -> IO ByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$
forall a. Binary a => a -> ByteString
Binary.encode @FullResponse
(Int
400, [], ByteString
"", ByteString
"Unreadable bridged subrequest data")
) BridgeConf -> IO ByteString
bridgedSubrequestFull (Maybe BridgeConf -> IO ByteString)
-> (ByteString -> Maybe BridgeConf) -> ByteString -> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Read a => ByteString -> Maybe a
readFromByteString @BridgeConf
ngxExportAsyncIOYY 'makeBridgedSubrequestFullWithRead