{-# LANGUAGE TemplateHaskell, OverloadedStrings, RecordWildCards #-}
{-# LANGUAGE TypeApplications, NumDecimals #-}
module NgxExport.Tools.Subrequest (
makeSubrequest
,makeSubrequestWithRead
,makeSubrequestFull
,makeSubrequestFullWithRead
,extractStatusFromFullResponse
,extractHeaderFromFullResponse
,extractBodyFromFullResponse
,extractExceptionFromFullResponse
,notForwardableResponseHeaders
,contentFromFullResponse
) where
import NgxExport
import NgxExport.Tools
import Network.HTTP.Client hiding (ResponseTimeout)
import qualified Network.HTTP.Client (HttpExceptionContent (ResponseTimeout))
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.Binary as Binary
import Data.HashSet (HashSet)
import qualified Data.HashSet as HS
import Data.CaseInsensitive hiding (map)
import Data.Aeson
import Data.Maybe
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
showList :: [SubrequestParseError] -> ShowS
$cshowList :: [SubrequestParseError] -> ShowS
show :: SubrequestParseError -> String
$cshow :: SubrequestParseError -> String
showsPrec :: Int -> SubrequestParseError -> ShowS
$cshowsPrec :: Int -> SubrequestParseError -> ShowS
Show
instance Exception SubrequestParseError
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
showList :: [UDSNotConfiguredError] -> ShowS
$cshowList :: [UDSNotConfiguredError] -> ShowS
show :: UDSNotConfiguredError -> String
$cshow :: UDSNotConfiguredError -> String
showsPrec :: Int -> UDSNotConfiguredError -> ShowS
$cshowsPrec :: Int -> UDSNotConfiguredError -> ShowS
Show
instance Exception UDSNotConfiguredError
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
/= :: ResponseTimeout -> ResponseTimeout -> Bool
$c/= :: ResponseTimeout -> ResponseTimeout -> Bool
== :: ResponseTimeout -> ResponseTimeout -> Bool
$c== :: 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
readListPrec :: ReadPrec [ResponseTimeout]
$creadListPrec :: ReadPrec [ResponseTimeout]
readPrec :: ReadPrec ResponseTimeout
$creadPrec :: ReadPrec ResponseTimeout
readList :: ReadS [ResponseTimeout]
$creadList :: ReadS [ResponseTimeout]
readsPrec :: Int -> ReadS ResponseTimeout
$creadsPrec :: Int -> ReadS ResponseTimeout
Read)
data SubrequestConf =
SubrequestConf { SubrequestConf -> ByteString
srMethod :: ByteString
, SubrequestConf -> String
srUri :: String
, SubrequestConf -> ByteString
srBody :: ByteString
, :: RequestHeaders
, SubrequestConf -> ResponseTimeout
srResponseTimeout :: ResponseTimeout
, SubrequestConf -> Bool
srUseUDS :: Bool
} 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
readListPrec :: ReadPrec [SubrequestConf]
$creadListPrec :: ReadPrec [SubrequestConf]
readPrec :: ReadPrec SubrequestConf
$creadPrec :: ReadPrec SubrequestConf
readList :: ReadS [SubrequestConf]
$creadList :: ReadS [SubrequestConf]
readsPrec :: Int -> ReadS SubrequestConf
$creadsPrec :: Int -> ReadS 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 "SubrequestConf" ((Object -> Parser SubrequestConf)
-> Value -> Parser SubrequestConf)
-> (Object -> Parser SubrequestConf)
-> Value
-> Parser SubrequestConf
forall a b. (a -> b) -> a -> b
$ \o :: Object
o -> do
ByteString
srMethod <- Parser (Maybe Text) -> Parser ByteString
maybeEmpty (Parser (Maybe Text) -> Parser ByteString)
-> Parser (Maybe Text) -> Parser ByteString
forall a b. (a -> b) -> a -> b
$ Object
o Object -> Text -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? "method"
String
srUri <- Object
o Object -> Text -> Parser String
forall a. FromJSON a => Object -> Text -> Parser a
.: "uri"
ByteString
srBody <- Parser (Maybe Text) -> Parser ByteString
maybeEmpty (Parser (Maybe Text) -> Parser ByteString)
-> Parser (Maybe Text) -> Parser ByteString
forall a b. (a -> b) -> a -> b
$ Object
o Object -> Text -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? "body"
RequestHeaders
srHeaders <- ((Text, Text) -> Header) -> [(Text, Text)] -> RequestHeaders
forall a b. (a -> b) -> [a] -> [b]
map (ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
mk (ByteString -> CI ByteString)
-> (Text -> ByteString) -> Text -> CI ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
T.encodeUtf8 (Text -> CI ByteString)
-> (Text -> ByteString) -> (Text, Text) -> Header
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 -> Text -> Parser (Maybe [(Text, Text)])
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? "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 -> Text -> Parser (Maybe TimeInterval)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? "timeout"
Bool
srUseUDS <- Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False (Maybe Bool -> Bool) -> Parser (Maybe Bool) -> Parser Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Text -> Parser (Maybe Bool)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? "useUDS"
SubrequestConf -> Parser SubrequestConf
forall (m :: * -> *) a. Monad m => a -> m a
return SubrequestConf :: ByteString
-> String
-> ByteString
-> RequestHeaders
-> ResponseTimeout
-> Bool
-> SubrequestConf
SubrequestConf {..}
where maybeEmpty :: Parser (Maybe Text) -> Parser ByteString
maybeEmpty = (Maybe Text -> ByteString)
-> Parser (Maybe Text) -> Parser ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Maybe Text -> ByteString)
-> Parser (Maybe Text) -> Parser ByteString)
-> (Maybe Text -> ByteString)
-> Parser (Maybe Text)
-> Parser ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> (Text -> ByteString) -> Maybe Text -> ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe "" Text -> ByteString
T.encodeUtf8
subrequest :: (String -> IO Request) ->
(Response L.ByteString -> L.ByteString) -> SubrequestConf ->
IO L.ByteString
subrequest :: (String -> IO Request)
-> (Response ByteString -> ByteString)
-> SubrequestConf
-> IO ByteString
subrequest parseRequestF :: String -> IO Request
parseRequestF buildResponseF :: Response ByteString -> ByteString
buildResponseF SubrequestConf {..} = do
Manager
man <- if Bool
srUseUDS
then 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
else Manager -> IO Manager
forall (m :: * -> *) a. Monad m => a -> m a
return Manager
httpManager
Request
req <- String -> IO Request
parseRequestF String
srUri
let req' :: Request
req' = if ByteString -> Bool
B.null ByteString
srMethod
then Request
req
else Request
req { method :: ByteString
method = ByteString
srMethod }
req'' :: Request
req'' = if ByteString -> Bool
B.null ByteString
srBody
then Request
req'
else Request
req' { requestBody :: RequestBody
requestBody = ByteString -> RequestBody
RequestBodyBS ByteString
srBody }
req''' :: Request
req''' = if RequestHeaders -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null RequestHeaders
srHeaders
then Request
req''
else Request
req'' { requestHeaders :: RequestHeaders
requestHeaders = RequestHeaders
srHeaders }
req'''' :: Request
req'''' = if ResponseTimeout
srResponseTimeout ResponseTimeout -> ResponseTimeout -> Bool
forall a. Eq a => a -> a -> Bool
== ResponseTimeout
ResponseTimeoutDefault
then Request
req'''
else Request
req''' { responseTimeout :: ResponseTimeout
responseTimeout =
ResponseTimeout -> ResponseTimeout
setTimeout ResponseTimeout
srResponseTimeout }
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)
httpLbs Request
req'''' Manager
man
where setTimeout :: ResponseTimeout -> ResponseTimeout
setTimeout (ResponseTimeout v :: TimeInterval
v)
| Int
t Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 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
* 1e6
where t :: Int
t = TimeInterval -> Int
toSec TimeInterval
v
setTimeout _ = ResponseTimeout
forall a. HasCallStack => a
undefined
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)
subrequestFull :: SubrequestConf -> IO L.ByteString
subrequestFull :: SubrequestConf -> IO ByteString
subrequestFull = IO ByteString -> IO ByteString
handleAll (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
buildResponse
where handleAll :: IO ByteString -> IO ByteString
handleAll = (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
$ \e :: 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
response500 :: (Int, [a], ByteString, ByteString)
response500 = (500, [], "", ByteString
msg)
response502 :: (Int, [a], ByteString, ByteString)
response502 = (502, [], "", ByteString
msg)
ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ Binary FullResponse => FullResponse -> ByteString
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 _ c :: HttpExceptionContent
c) ->
case HttpExceptionContent
c of
Network.HTTP.Client.ResponseTimeout -> FullResponse
forall a. (Int, [a], ByteString, ByteString)
response502
ConnectionTimeout -> FullResponse
forall a. (Int, [a], ByteString, ByteString)
response502
ConnectionFailure _ -> FullResponse
forall a. (Int, [a], ByteString, ByteString)
response502
_ -> FullResponse
forall a. (Int, [a], ByteString, ByteString)
response500
_ -> FullResponse
forall a. (Int, [a], ByteString, ByteString)
response500
buildResponse :: Response ByteString -> ByteString
buildResponse r :: 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 = (Header -> (ByteString, ByteString))
-> RequestHeaders -> [(ByteString, ByteString)]
forall a b. (a -> b) -> [a] -> [b]
map ((CI ByteString -> ByteString) -> Header -> (ByteString, ByteString)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first CI ByteString -> 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 FullResponse -> ByteString
forall a. Binary a => a -> ByteString
Binary.encode @FullResponse (Int
status, [(ByteString, ByteString)]
headers, ByteString
body, "")
httpManager :: Manager
httpManager :: Manager
httpManager = IO Manager -> Manager
forall a. IO a -> a
unsafePerformIO (IO Manager -> Manager) -> IO Manager -> Manager
forall a b. (a -> b) -> a -> b
$ ManagerSettings -> IO Manager
newManager ManagerSettings
defaultManagerSettings
{-# 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 #-}
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
.
FromJSON SubrequestConf => ByteString -> Maybe SubrequestConf
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
.
Read SubrequestConf => ByteString -> Maybe SubrequestConf
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
readListPrec :: ReadPrec [UDSConf]
$creadListPrec :: ReadPrec [UDSConf]
readPrec :: ReadPrec UDSConf
$creadPrec :: ReadPrec UDSConf
readList :: ReadS [UDSConf]
$creadList :: ReadS [UDSConf]
readsPrec :: Int -> ReadS UDSConf
$creadsPrec :: Int -> ReadS UDSConf
Read
configureUDS :: UDSConf -> Bool -> IO L.ByteString
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 {..} -> do
Manager
man <- ManagerSettings -> IO Manager
newManager ManagerSettings
defaultManagerSettings
{ managerRawConnection :: IO (Maybe HostAddress -> String -> Int -> IO Connection)
managerRawConnection = (Maybe HostAddress -> String -> Int -> IO Connection)
-> IO (Maybe HostAddress -> String -> Int -> IO Connection)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Maybe HostAddress -> String -> Int -> IO Connection)
-> IO (Maybe HostAddress -> String -> Int -> IO Connection))
-> (Maybe HostAddress -> String -> Int -> IO Connection)
-> IO (Maybe HostAddress -> String -> Int -> IO Connection)
forall a b. (a -> b) -> a -> b
$ String -> Maybe HostAddress -> String -> Int -> IO Connection
forall p p p. String -> p -> p -> p -> IO Connection
openUDS String
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
ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ""
where openUDS :: String -> p -> p -> p -> IO Connection
openUDS path :: String
path _ _ _ = 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 4096) (Socket -> ByteString -> IO ()
SB.sendAll Socket
s) (Socket -> IO ()
S.close Socket
s)
ngxExportSimpleServiceTyped 'configureUDS ''UDSConf SingleShotService
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 (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$
FullResponse -> ByteString
forall a. Binary a => a -> ByteString
Binary.encode @FullResponse
(400, [], "", "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
. FromJSON SubrequestConf => ByteString -> Maybe SubrequestConf
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 (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$
FullResponse -> ByteString
forall a. Binary a => a -> ByteString
Binary.encode @FullResponse
(400, [], "", "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
. Read SubrequestConf => ByteString -> Maybe SubrequestConf
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
.
(\(a :: Int
a, _, _, _) -> Int
a) (FullResponse -> Int)
-> (ByteString -> FullResponse) -> ByteString -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Binary FullResponse => ByteString -> FullResponse
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
v :: ByteString
v =
let (h :: CI ByteString
h, b :: ByteString
b) = ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
mk (ByteString -> CI ByteString)
-> (ByteString -> ByteString) -> (ByteString, ByteString) -> Header
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** ByteString -> ByteString
C8.tail ((ByteString, ByteString) -> Header)
-> (ByteString, ByteString) -> Header
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> ByteString -> (ByteString, ByteString)
C8.break ('|' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==) ByteString
v
(_, hs :: [(ByteString, ByteString)]
hs, _, _) = Binary FullResponse => ByteString -> FullResponse
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
L.fromStrict (Maybe ByteString -> ByteString) -> Maybe ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ CI ByteString -> RequestHeaders -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup CI ByteString
h (RequestHeaders -> Maybe ByteString)
-> RequestHeaders -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ ((ByteString, ByteString) -> Header)
-> [(ByteString, ByteString)] -> RequestHeaders
forall a b. (a -> b) -> [a] -> [b]
map ((ByteString -> CI ByteString) -> (ByteString, ByteString) -> Header
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
mk) [(ByteString, ByteString)]
hs
extractBodyFromFullResponse
:: ByteString
-> L.ByteString
extractBodyFromFullResponse :: ByteString -> ByteString
extractBodyFromFullResponse =
(\(_, _, a :: ByteString
a, _) -> ByteString
a) (FullResponse -> ByteString)
-> (ByteString -> FullResponse) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Binary FullResponse => ByteString -> FullResponse
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
.
(\(_, _, _, a :: ByteString
a) -> ByteString
a) (FullResponse -> ByteString)
-> (ByteString -> FullResponse) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Binary FullResponse => ByteString -> FullResponse
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
= [CI ByteString] -> HashSet (CI ByteString)
forall a. (Eq a, Hashable a) => [a] -> HashSet a
HS.fromList ([CI ByteString] -> HashSet (CI ByteString))
-> [CI ByteString] -> HashSet (CI ByteString)
forall a b. (a -> b) -> a -> b
$
(ByteString -> CI ByteString) -> [ByteString] -> [CI ByteString]
forall a b. (a -> b) -> [a] -> [b]
map ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
mk ["Connection"
,"Content-Length"
,"Content-Type"
,"Date"
,"Keep-Alive"
,"Last-Modified"
,"Server"
,"Transfer-Encoding"
,"X-Pad"
]
contentFromFullResponse
:: HashSet HeaderName
-> Bool
-> (L.ByteString -> ByteString -> L.ByteString)
-> ByteString
-> ContentHandlerResult
contentFromFullResponse :: HashSet (CI ByteString)
-> Bool
-> (ByteString -> ByteString -> ByteString)
-> ByteString
-> ContentHandlerResult
contentFromFullResponse headersToDelete :: HashSet (CI ByteString)
headersToDelete deleteXAccel :: Bool
deleteXAccel f :: ByteString -> ByteString -> ByteString
f v :: ByteString
v =
let (st :: Int
st, hs :: [(ByteString, ByteString)]
hs, b :: ByteString
b, e :: ByteString
e) = Binary FullResponse => ByteString -> FullResponse
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) -> Header)
-> [(ByteString, ByteString)] -> RequestHeaders
forall a b. (a -> b) -> [a] -> [b]
map ((ByteString -> CI ByteString) -> (ByteString, ByteString) -> Header
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ByteString -> CI ByteString
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 "" (Maybe ByteString -> ByteString) -> Maybe ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ CI ByteString -> RequestHeaders -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
mk "Content-Type") RequestHeaders
hs'
hs'' :: RequestHeaders
hs'' = (Header -> Bool) -> RequestHeaders -> RequestHeaders
forall a. (a -> Bool) -> [a] -> [a]
filter
(\(n :: CI ByteString
n, _) -> Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$
CI ByteString
n CI ByteString -> HashSet (CI ByteString) -> Bool
forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
`HS.member` HashSet (CI ByteString)
headersToDelete Bool -> Bool -> Bool
||
Bool
deleteXAccel Bool -> Bool -> Bool
&&
ByteString -> ByteString
forall s. FoldCase s => s -> s
foldCase "X-Accel-" ByteString -> ByteString -> Bool
`B.isPrefixOf` CI ByteString -> ByteString
forall s. CI s -> s
foldedCase CI ByteString
n
) RequestHeaders
hs'
in (ByteString -> ByteString -> ByteString
f ByteString
b ByteString
e, ByteString
ct, Int
st, (Header -> (ByteString, ByteString))
-> RequestHeaders -> [(ByteString, ByteString)]
forall a b. (a -> b) -> [a] -> [b]
map ((CI ByteString -> ByteString) -> Header -> (ByteString, ByteString)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first CI ByteString -> ByteString
forall s. CI s -> s
original) RequestHeaders
hs'')
fromFullResponse :: ByteString -> ContentHandlerResult
fromFullResponse :: ByteString -> ContentHandlerResult
fromFullResponse =
HashSet (CI ByteString)
-> Bool
-> (ByteString -> ByteString -> ByteString)
-> ByteString
-> ContentHandlerResult
contentFromFullResponse HashSet (CI ByteString)
notForwardableResponseHeaders Bool
True ByteString -> ByteString -> ByteString
forall a b. a -> b -> a
const
ngxExportHandler 'fromFullResponse
fromFullResponseWithException :: ByteString -> ContentHandlerResult
fromFullResponseWithException :: ByteString -> ContentHandlerResult
fromFullResponseWithException =
HashSet (CI ByteString)
-> Bool
-> (ByteString -> ByteString -> ByteString)
-> ByteString
-> ContentHandlerResult
contentFromFullResponse HashSet (CI ByteString)
notForwardableResponseHeaders Bool
True ByteString -> ByteString -> ByteString
f
where f :: ByteString -> ByteString -> ByteString
f "" = ByteString -> ByteString
L.fromStrict
f b :: ByteString
b = ByteString -> ByteString -> ByteString
forall a b. a -> b -> a
const ByteString
b
ngxExportHandler 'fromFullResponseWithException