{-# LANGUAGE TemplateHaskell, OverloadedStrings, RecordWildCards #-}
{-# LANGUAGE TypeApplications, TupleSections, NumDecimals #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  NgxExport.Tools.Subrequest
-- Copyright   :  (c) Alexey Radkov 2020-2021
-- License     :  BSD-style
--
-- Maintainer  :  alexey.radkov@gmail.com
-- Stability   :  experimental
-- Portability :  non-portable (requires Template Haskell)
--
-- Easy HTTP subrequests from the more extra tools collection for
-- <http://github.com/lyokha/nginx-haskell-module nginx-haskell-module>.
--
-----------------------------------------------------------------------------


module NgxExport.Tools.Subrequest (
    -- * Making HTTP subrequests
    -- $makingHTTPSubrequests
                                   makeSubrequest
                                  ,makeSubrequestWithRead
    -- * Internal HTTP subrequests via Unix domain sockets
    -- $internalHTTPSubrequests

    -- * Getting full response data from HTTP subrequests
    -- $gettingFullResponse
                                  ,makeSubrequestFull
                                  ,makeSubrequestFullWithRead
                                  ,extractStatusFromFullResponse
                                  ,extractHeaderFromFullResponse
                                  ,extractBodyFromFullResponse
                                  ,extractExceptionFromFullResponse
    -- * Forwarding full response data to the client
    -- $forwardingFullResponse
                                  ,notForwardableResponseHeaders
                                  ,contentFromFullResponse
    -- * Making bridged HTTP subrequests
    -- $makingBridgedHTTPSubrequests
                                  ,makeBridgedSubrequest
                                  ,makeBridgedSubrequestWithRead
                                  ,makeBridgedSubrequestFull
                                  ,makeBridgedSubrequestFullWithRead
                                  ) 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.Function
import           Data.Aeson
import           Data.Maybe
import           Data.List
import           Control.Arrow
import           Control.Exception
import           System.IO.Unsafe

-- $makingHTTPSubrequests
--
-- Using asynchronous variable handlers and services together with the HTTP
-- client from "Network.HTTP.Client" allows making HTTP subrequests easily.
-- This module provides such functionality by exporting asynchronous variable
-- handlers __/makeSubrequest/__ and __/makeSubrequestWithRead/__, and functions
-- 'makeSubrequest' and 'makeSubrequestWithRead' to build custom handlers.
--
-- Below is a simple example.
--
-- ==== File /test_tools_extra_subrequest.hs/
-- @
-- {-\# LANGUAGE TemplateHaskell \#-}
--
-- module TestToolsExtraSubrequest where
--
-- import           NgxExport
-- import           NgxExport.Tools
-- import           NgxExport.Tools.Subrequest
--
-- import           Data.ByteString (ByteString)
-- import qualified Data.ByteString.Lazy as L
--
-- makeRequest :: ByteString -> Bool -> IO L.ByteString
-- __/makeRequest/__ = const . 'makeSubrequest'
--
-- 'ngxExportSimpleService' \'makeRequest $ 'PersistentService' $ Just $ 'Sec' 10
-- @
--
-- Handler /makeRequest/ will be used in a /periodical/ service which will
-- retrieve data from a specified URI every 10 seconds.
--
-- ==== File /nginx.conf/
-- @
-- user                    nobody;
-- worker_processes        2;
--
-- events {
--     worker_connections  1024;
-- }
--
-- http {
--     default_type        application\/octet-stream;
--     sendfile            on;
--
--     haskell load \/var\/lib\/nginx\/test_tools_extra_subrequest.so;
--
--     upstream backend {
--         server 127.0.0.1:8020;
--     }
--
--     haskell_run_service __/simpleService_makeRequest/__ $hs_service_httpbin
--             \'{\"uri\": \"http:\/\/httpbin.org\"}\';
--
--     haskell_var_empty_on_error $hs_subrequest;
--
--     server {
--         listen       8010;
--         server_name  main;
--         error_log    \/tmp\/nginx-test-haskell-error.log;
--         access_log   \/tmp\/nginx-test-haskell-access.log;
--
--         location \/ {
--             haskell_run_async __/makeSubrequest/__ $hs_subrequest
--                     \'{\"uri\": \"http:\/\/127.0.0.1:8010\/proxy\"
--                      ,\"headers\": [[\"Custom-Header\", \"$arg_a\"]]
--                      }\';
--
--             if ($hs_subrequest = \'\') {
--                 echo_status 404;
--                 echo \"Failed to perform subrequest\";
--                 break;
--             }
--
--             echo -n $hs_subrequest;
--         }
--
--         location ~ ^\/proxy(.*) {
--             allow 127.0.0.1;
--             deny all;
--             proxy_pass http:\/\/backend$1;
--         }
--
--         location \/httpbin {
--             echo $hs_service_httpbin;
--         }
--     }
--
--     server {
--         listen       8020;
--         server_name  backend;
--
--         location\ / {
--             set $custom_header $http_custom_header;
--             echo \"In backend, Custom-Header is \'$custom_header\'\";
--         }
--     }
-- }
-- @
--
-- Configurations of subrequests are defined via JSON objects which contain URI
-- and other relevant data such as HTTP method, request body and headers. In
-- this configuration we are running a periodical service which gets contents of
-- /httpbin.org/ every 10 seconds, and doing a subrequest to a virtual server
-- /backend/ on every request to location /\//. In this subrequest, an HTTP
-- header /Custom-Header/ is sent to the backend with value equal to the value
-- of argument /a/ from the client request's URI.
--
-- It is worth noting that making HTTP subrequests to the own Nginx service
-- (e.g. via /127.0.0.1/) allows for leveraging well-known advantages of Nginx
-- such as load-balancing via upstreams as it is happening in this example.
--
-- ==== A simple test
--
-- > $ curl -s 'http://localhost:8010/httpbin' | head
-- > <!DOCTYPE html>
-- > <html lang="en">
-- >
-- > <head>
-- >     <meta charset="UTF-8">
-- >     <title>httpbin.org</title>
-- >     <link href="https://fonts.googleapis.com/css?family=Open+Sans:400,700|Source+Code+Pro:300,600|Titillium+Web:400,600,700"
-- >         rel="stylesheet">
-- >     <link rel="stylesheet" type="text/css" href="/flasgger_static/swagger-ui.css">
-- >     <link rel="icon" type="image/png" href="/static/favicon.ico" sizes="64x64 32x32 16x16" />
--
-- > $ curl 'http://localhost:8010/?a=Value'
-- > In backend, Custom-Header is 'Value'
--
-- Let's do a nasty thing. By injecting a comma into the argument /a/ we shall
-- break JSON parsing.
--
-- > $ curl -D- 'http://localhost:8010/?a=Value"'
-- > HTTP/1.1 404 Not Found
-- > Server: nginx/1.17.9
-- > Date: Mon, 30 Mar 2020 14:42:42 GMT
-- > Content-Type: application/octet-stream
-- > Transfer-Encoding: chunked
-- > Connection: keep-alive
-- >
-- > Failed to perform subrequest

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 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
showList :: [BridgeParseError] -> ShowS
$cshowList :: [BridgeParseError] -> ShowS
show :: BridgeParseError -> String
$cshow :: BridgeParseError -> String
showsPrec :: Int -> BridgeParseError -> ShowS
$cshowsPrec :: Int -> 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
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
                   , SubrequestConf -> RequestHeaders
srHeaders         :: 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

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
readListPrec :: ReadPrec [BridgeConf]
$creadListPrec :: ReadPrec [BridgeConf]
readPrec :: ReadPrec BridgeConf
$creadPrec :: ReadPrec BridgeConf
readList :: ReadS [BridgeConf]
$creadList :: ReadS [BridgeConf]
readsPrec :: Int -> ReadS BridgeConf
$creadsPrec :: Int -> ReadS 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 "BridgeConf" ((Object -> Parser BridgeConf) -> Value -> Parser BridgeConf)
-> (Object -> Parser BridgeConf) -> Value -> Parser BridgeConf
forall a b. (a -> b) -> a -> b
$ \o :: Object
o -> do
        SubrequestConf
bridgeSource <- Object
o Object -> Text -> Parser SubrequestConf
forall a. FromJSON a => Object -> Text -> Parser a
.: "source"
        SubrequestConf
bridgeSink <- Object
o Object -> Text -> Parser SubrequestConf
forall a. FromJSON a => Object -> Text -> Parser a
.: "sink"
        BridgeConf -> Parser BridgeConf
forall (m :: * -> *) a. Monad m => a -> m a
return BridgeConf :: SubrequestConf -> SubrequestConf -> BridgeConf
BridgeConf {..}

makeRequest :: SubrequestConf -> Request -> Request
makeRequest :: SubrequestConf -> Request -> Request
makeRequest SubrequestConf {..} req :: Request
req =
    Request
req { method :: ByteString
method = if ByteString -> Bool
B.null ByteString
srMethod
                       then Request -> ByteString
method Request
req
                       else ByteString
srMethod
        , requestBody :: RequestBody
requestBody = if ByteString -> Bool
B.null ByteString
srBody
                            then Request -> RequestBody
requestBody Request
req
                            else ByteString -> RequestBody
RequestBodyBS ByteString
srBody
        , requestHeaders :: RequestHeaders
requestHeaders = (Header -> Header -> Bool)
-> RequestHeaders -> RequestHeaders -> RequestHeaders
forall a. (a -> a -> Bool) -> [a] -> [a] -> [a]
unionBy (CI ByteString -> CI ByteString -> Bool
forall a. Eq a => a -> a -> Bool
(==) (CI ByteString -> CI ByteString -> Bool)
-> (Header -> CI ByteString) -> Header -> Header -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Header -> CI ByteString
forall a b. (a, b) -> a
fst) RequestHeaders
srHeaders (RequestHeaders -> RequestHeaders)
-> RequestHeaders -> RequestHeaders
forall a b. (a -> b) -> a -> b
$
                               Request -> RequestHeaders
requestHeaders Request
req
        , responseTimeout :: ResponseTimeout
responseTimeout = if ResponseTimeout
srResponseTimeout ResponseTimeout -> ResponseTimeout -> Bool
forall a. Eq a => a -> a -> Bool
== ResponseTimeout
ResponseTimeoutDefault
                                then Request -> ResponseTimeout
responseTimeout Request
req
                                else ResponseTimeout -> ResponseTimeout
setTimeout ResponseTimeout
srResponseTimeout
        }
    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

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 sub :: SubrequestConf
sub@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
    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 (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
$ \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
        responseXXX :: t -> (t, [a], ByteString, ByteString)
responseXXX = (, [], "", ByteString
msg)
        response500 :: (Int, [a], ByteString, ByteString)
response500 = Int -> (Int, [a], ByteString, ByteString)
forall t a. t -> (t, [a], ByteString, ByteString)
responseXXX 500
        response502 :: (Int, [a], ByteString, ByteString)
response502 = Int -> (Int, [a], ByteString, ByteString)
forall t a. t -> (t, [a], ByteString, ByteString)
responseXXX 502
    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
                    StatusCodeException r :: Response ()
r _ ->
                        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
                    _ -> FullResponse
forall a. (Int, [a], ByteString, ByteString)
response500
            _ -> FullResponse
forall a. (Int, [a], ByteString, ByteString)
response500

buildFullResponse :: Response L.ByteString -> L.ByteString
buildFullResponse :: Response ByteString -> ByteString
buildFullResponse 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, "")

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 -> 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 #-}

-- | Makes an HTTP request.
--
-- This is the core function of the /makeSubrequest/ handler. From perspective
-- of an Nginx request, it spawns a subrequest, hence the name. However, this
-- function can also be used to initiate an original HTTP request from a
-- service handler.
--
-- Accepts a JSON object representing an opaque type /SubrequestConf/.
-- The object may contain 5 fields: /method/ (optional, default is /GET/),
-- /uri/ (mandatory), /body/ (optional, default is an empty value), /headers/
-- (optional, default is an empty array), and /timeout/ (optional, default is
-- the default response timeout of the HTTP manager which is normally 30
-- seconds, use value @{\"tag\": \"Unset\"}@ to disable response timeout
-- completely).
--
-- Examples of subrequest configurations:
--
-- > {"uri": "http://example.com/", "timeout": {"tag": "Sec", "contents": 10}}
--
-- > {"uri": "http://127.0.0.1/subreq", "method": "POST", "body": "some value"}
--
-- > {"uri": "http://127.0.0.1/subreq"
-- > ,"headers": [["Header1", "Value1"], ["Header2", "Value2"]]
-- > }
--
-- Returns the response body if HTTP status of the response is /2xx/, otherwise
-- throws an error. To avoid leakage of error messages into variable handlers,
-- put the corresponding variables into the list of directive
-- /haskell_var_empty_on_error/.
makeSubrequest
    :: ByteString       -- ^ Subrequest configuration
    -> 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

-- | Makes an HTTP request.
--
-- Behaves exactly as 'makeSubrequest' except it parses Haskell terms
-- representing /SubrequestConf/ with 'read'. Exported on the Nginx level by
-- handler /makeSubrequestWithRead/.
--
-- An example of a subrequest configuration:
--
-- > SubrequestConf { srMethod = ""
-- >                , srUri = "http://127.0.0.1/subreq"
-- >                , srBody = ""
-- >                , srHeaders = [("Header1", "Value1"), ("Header2", "Value2")]
-- >                , srResponseTimeout = ResponseTimeout (Sec 10)
-- >                , srUseUDS = False
-- >                }
--
-- Notice that unlike JSON parsing, fields of /SubrequestConf/ are not
-- omittable and must be listed in the order shown in the example. Empty
-- /srMethod/ implies /GET/.
makeSubrequestWithRead
    :: ByteString       -- ^ Subrequest configuration
    -> 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

-- $internalHTTPSubrequests
--
-- Making HTTP subrequests to the own Nginx service via the loopback interface
-- (e.g. via /127.0.0.1/) has disadvantages of being neither very fast (if
-- compared with various types of local data communication channels) nor very
-- secure. Unix domain sockets is a better alternative in this sense. This
-- module has support for them by providing configuration service
-- __/simpleService_configureUDS/__ where path to the socket can be set, and an
-- extra field /srUseUDS/ in data /SubrequestConf/.
--
-- To extend the previous example for using with Unix domain sockets, the
-- following declarations should be added.
--
-- ==== File /nginx.conf/: configuring the Unix domain socket
-- @
--     haskell_run_service __/simpleService_configureUDS/__ $hs_service_uds
--             \'__/UDSConf/__ {__/udsPath/__ = \"\/tmp\/backend.sock\"}\';
-- @
--
-- /UDSConf/ is an opaque type containing only one field /udsPath/ with the path
-- to the socket.
--
-- ==== File /nginx.conf/: new location /\/uds/ in server /main/
-- @
--         location \/uds {
--             haskell_run_async __/makeSubrequest/__ $hs_subrequest
--                     \'{\"uri\": \"http:\/\/backend_proxy\/\"
--                      ,\"headers\": [[\"Custom-Header\", \"$arg_a\"]]
--                      ,\"__/useUDS/__\": __/true/__
--                      }\';
--
--             if ($hs_subrequest = \'\') {
--                 echo_status 404;
--                 echo \"Failed to perform subrequest\";
--                 break;
--             }
--
--             echo -n $hs_subrequest;
--         }
-- @
--
-- ==== File /nginx.conf/: new virtual server /backend_proxy/
-- @
--     server {
--         listen       unix:\/tmp\/backend.sock;
--         server_name  backend_proxy;
--
--         location \/ {
--             proxy_pass http:\/\/backend;
--         }
--     }
-- @
--
-- The server listens on the Unix domain socket with the path configured in
-- service /simpleService_configureUDS/.
--
-- ==== A simple test
--
-- > $ curl 'http://localhost:8010/uds?a=Value'
-- > In backend, Custom-Header is 'Value'

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

-- $gettingFullResponse
--
-- Handlers /makeSubrequest/ and /makeSubrequestWithRead/ return response body
-- of subrequests skipping the response status and headers. To retrieve full
-- data from a response, use another pair of asynchronous variable handlers and
-- functions: __/makeSubrequestFull/__ and __/makeSubrequestFullWithRead/__,
-- and 'makeSubrequestFull' and 'makeSubrequestFullWithRead' respectively.
--
-- Unlike the simple body handlers, there is no sense of using the corresponding
-- variables directly as they are binary encoded values. Instead, the response
-- status, headers and the body must be extracted using handlers
-- __/extractStatusFromFullResponse/__, __/extractHeaderFromFullResponse/__,
-- and __/extractBodyFromFullResponse/__ which are based on functions of the
-- same name. Handler __/extractExceptionFromFullResponse/__ and the
-- corresponding function can be used to extract the error message if an
-- exception has happened while making the subrequest: the value is empty if
-- there was no exception.
--
-- Let's extend our example with these handlers.
--
-- File /test_tools_extra_subrequest.hs/ does not have any changes as we are
-- going to use exported handlers only.
--
-- ==== File /nginx.conf/: new location /\/full/ in server /main/
-- @
--         location \/full {
--             haskell_run_async __/makeSubrequestFull/__ $hs_subrequest
--                     \'{\"uri\": \"http:\/\/127.0.0.1:$arg_p\/proxy\"
--                      ,\"headers\": [[\"Custom-Header\", \"$arg_a\"]]
--                      }\';
--
--             haskell_run __/extractStatusFromFullResponse/__ $hs_subrequest_status
--                     $hs_subrequest;
--
--             haskell_run __/extractHeaderFromFullResponse/__ $hs_subrequest_header
--                     subrequest-header|$hs_subrequest;
--
--             haskell_run __/extractBodyFromFullResponse/__ $hs_subrequest_body
--                     $hs_subrequest;
--
--             if ($hs_subrequest_status = 400) {
--                 echo_status 400;
--                 echo \"Bad request\";
--                 break;
--             }
--
--             if ($hs_subrequest_status = 500) {
--                 echo_status 500;
--                 echo \"Internal server error while making subrequest\";
--                 break;
--             }
--
--             if ($hs_subrequest_status = 502) {
--                 echo_status 502;
--                 echo \"Backend unavailable\";
--                 break;
--             }
--
--             if ($hs_subrequest_status != 200) {
--                 echo_status 404;
--                 echo \"Subrequest status: $hs_subrequest_status\";
--                 break;
--             }
--
--             echo    \"Subrequest status: $hs_subrequest_status\";
--             echo    \"Subrequest-Header: $hs_subrequest_header\";
--             echo -n \"Subrequest body: $hs_subrequest_body\";
--         }
-- @
--
-- Now we can recognize HTTP response statuses of subrequests and handle them
-- differently. We also can read a response header /Subrequest-Header/.
--
-- ==== File /nginx.conf/: new response header /Subrequest-Header/ in location /\// of server /backend/
-- @
--             add_header Subrequest-Header \"This is response from subrequest\";
-- @
--
-- ==== A simple test
--
-- > $ curl -D- 'http://localhost:8010/full/?a=Value"'
-- > HTTP/1.1 400 Bad Request
-- > Server: nginx/1.17.9
-- > Date: Sat, 04 Apr 2020 12:44:36 GMT
-- > Content-Type: application/octet-stream
-- > Transfer-Encoding: chunked
-- > Connection: keep-alive
-- >
-- > Bad request
--
-- Good. Now we see that adding a comma into a JSON field is a bad request.
--
-- > $ curl -D- 'http://localhost:8010/full/?a=Value'
-- > HTTP/1.1 500 Internal Server Error
-- > Server: nginx/1.17.9
-- > Date: Sat, 04 Apr 2020 12:47:11 GMT
-- > Content-Type: application/octet-stream
-- > Transfer-Encoding: chunked
-- > Connection: keep-alive
-- >
-- > Internal server error while making subrequest
--
-- This is also good. Now we are going to define port of the backend server via
-- argument /$arg_p/. Skipping this makes URI look unparsable
-- (/http:\/\/127.0.0.1:\//) which leads to the error.
--
-- > $ curl -D- 'http://localhost:8010/full/?a=Value&p=8020'
-- > HTTP/1.1 200 OK
-- > Server: nginx/1.17.9
-- > Date: Sat, 04 Apr 2020 12:52:03 GMT
-- > Content-Type: application/octet-stream
-- > Transfer-Encoding: chunked
-- > Connection: keep-alive
-- >
-- > Subrequest status: 200
-- > Subrequest-Header: This is response from subrequest
-- > Subrequest body: In backend, Custom-Header is 'Value'
--
-- Finally, we are getting a good response with all the response data decoded
-- correctly.
--
-- Let's try another port.
--
-- > $ curl -D- 'http://localhost:8010/full/?a=Value&p=8021'
-- > HTTP/1.1 502 Bad Gateway
-- > Server: nginx/1.17.9
-- > Date: Sat, 04 Apr 2020 12:56:02 GMT
-- > Content-Type: application/octet-stream
-- > Transfer-Encoding: chunked
-- > Connection: keep-alive
-- >
-- > Backend unavailable
--
-- Good. There is no server listening on port 8021.

-- | Makes an HTTP request.
--
-- The same as 'makeSubrequest' except it returns a binary encoded response data
-- whose parts must be extracted by handlers made of
-- 'extractStatusFromFullResponse', 'extractHeaderFromFullResponse',
-- 'extractBodyFromFullResponse', and 'extractExceptionFromFullResponse'. It
-- does not throw any exceptions outside. Exported on the Nginx level by handler
-- /makeSubrequestFull/.
makeSubrequestFull
    :: ByteString       -- ^ Subrequest configuration
    -> 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

-- | Makes an HTTP request.
--
-- The same as 'makeSubrequestWithRead' except it returns a binary encoded
-- response data whose parts must be extracted by handlers made of
-- 'extractStatusFromFullResponse', 'extractHeaderFromFullResponse',
-- 'extractBodyFromFullResponse', and 'extractExceptionFromFullResponse'. It
-- does not throw any exceptions outside. Exported on the Nginx level by handler
-- /makeSubrequestFullWithRead/.
makeSubrequestFullWithRead
    :: ByteString       -- ^ Subrequest configuration
    -> 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

-- | Extracts the HTTP status from an encoded response.
--
-- Must be used to extract response data encoded by 'makeSubrequestFull' or
-- 'makeSubrequestFullWithRead'. Exported on the Nginx level by handler
-- /extractStatusFromFullResponse/.
extractStatusFromFullResponse
    :: ByteString       -- ^ Encoded HTTP response
    -> L.ByteString
extractStatusFromFullResponse :: ByteString -> ByteString
extractStatusFromFullResponse = 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

ngxExportYY 'extractStatusFromFullResponse

-- | Extracts a specified header from an encoded response.
--
-- Must be used to extract response data encoded by 'makeSubrequestFull' or
-- 'makeSubrequestFullWithRead'. Exported on the Nginx level by handler
-- /extractHeaderFromFullResponse/.
--
-- Expects that the encoded response data is attached after the name of the
-- header and a vertical bar such as /Header-Name|$hs_body/. The lookup of the
-- header name is case-insensitive. Returns an empty value if the header was not
-- found.
extractHeaderFromFullResponse
    :: ByteString       -- ^ Encoded HTTP response
    -> L.ByteString
extractHeaderFromFullResponse :: ByteString -> ByteString
extractHeaderFromFullResponse 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

ngxExportYY 'extractHeaderFromFullResponse

-- | Extracts the body from an encoded response.
--
-- Must be used to extract response data encoded by 'makeSubrequestFull' or
-- 'makeSubrequestFullWithRead'. Exported on the Nginx level by handler
-- /extractBodyFromFullResponse/.
extractBodyFromFullResponse
    :: ByteString       -- ^ Encoded HTTP response
    -> 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

-- | Extracts the exception from an encoded response.
--
-- Must be used to extract response data encoded by 'makeSubrequestFull' or
-- 'makeSubrequestFullWithRead'. Exported on the Nginx level by handler
-- /extractExceptionFromFullResponse/.
--
-- The empty value implies that there was no exception while making the
-- subrequest. Non-/2xx/ responses are not regarded as exceptions as well.
extractExceptionFromFullResponse
    :: ByteString       -- ^ Encoded HTTP response
    -> L.ByteString
extractExceptionFromFullResponse :: ByteString -> ByteString
extractExceptionFromFullResponse = 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

ngxExportYY 'extractExceptionFromFullResponse

-- $forwardingFullResponse
--
-- Data encoded in the full response can be translated to 'ContentHandlerResult'
-- and forwarded downstream to the client in directive /haskell_content/.
-- Handlers __/fromFullResponse/__ and __/fromFullResponseWithException/__
-- perform such a translation. Not all response headers are allowed being
-- forwarded downstream, and thus the handlers delete response headers with
-- names listed in set 'notForwardableResponseHeaders' as well as all headers
-- with names starting with /X-Accel-/ before sending the response to the
-- client. The set of not forwardable response headers can be customized in
-- function 'contentFromFullResponse'.
--
-- Let's forward responses in location /\/full/ when argument /proxy/ in the
-- client request's URI is equal to /yes/.
--
-- ==== File /nginx.conf/: forward responses from location /\/full/
-- @
--             set $proxy_with_exception $arg_proxy$arg_exc;
--
--             if ($proxy_with_exception = yesyes) {
--                 haskell_content __/fromFullResponseWithException/__ $hs_subrequest;
--                 break;
--             }
--
--             if ($arg_proxy = yes) {
--                 haskell_content __/fromFullResponse/__ $hs_subrequest;
--                 break;
--             }
-- @
--
-- ==== A simple test
--
-- > $ curl -D- 'http://localhost:8010/full/?a=Value&p=8020&proxy=yes'
-- > HTTP/1.1 200 OK
-- > Server: nginx/1.17.9
-- > Date: Fri, 24 Jul 2020 13:14:33 GMT
-- > Content-Type: application/octet-stream
-- > Content-Length: 37
-- > Connection: keep-alive
-- > Subrequest-Header: This is response from subrequest
-- >
-- > In backend, Custom-Header is 'Value'
--
-- Now let's get an error message in the response after feeding a wrong port
-- value.
--
-- > $ curl -D- 'http://localhost:8010/full/?a=Value&p=8021&proxy=yes&exc=yes'
-- > HTTP/1.1 502 Bad Gateway
-- > Server: nginx/1.19.4
-- > Date: Mon, 14 Dec 2020 08:24:22 GMT
-- > Content-Length: 593
-- > Connection: keep-alive
-- >
-- > HttpExceptionRequest Request {
-- >   host                 = "127.0.0.1"
-- >   port                 = 8021
-- >   secure               = False
-- >   requestHeaders       = [("Custom-Header","Value")]
-- >   path                 = "/proxy"
-- >   queryString          = ""
-- >   method               = "GET"
-- >   proxy                = Nothing
-- >   rawBody              = False
-- >   redirectCount        = 10
-- >   responseTimeout      = ResponseTimeoutDefault
-- >   requestVersion       = HTTP/1.1
-- >   proxySecureMode      = ProxySecureWithConnect
-- > }
-- >  (ConnectionFailure Network.Socket.connect: <socket: 31>: does not exist (Connection refused))

-- | Default set of not forwardable response headers.
--
-- HTTP response headers that won't be forwarded to the client in handler
-- /fromFullResponse/. The set contains /Connection/, /Content-Length/, /Date/,
-- /Keep-Alive/, /Last-Modified/, /Server/, /Transfer-Encoding/, and
-- /Content-Type/ headers (the latter gets reset in the handler's result value).
-- If this set is not satisfactory, then handler /fromFullResponse/ must be
-- replaced with a custom handler based on 'contentFromFullResponse' with a
-- customized set of not forwardable response headers.
notForwardableResponseHeaders :: HashSet HeaderName
notForwardableResponseHeaders :: HashSet (CI ByteString)
notForwardableResponseHeaders = [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"
           ]

deleteHeaders :: HashSet HeaderName -> Bool -> ResponseHeaders ->
    ResponseHeaders
deleteHeaders :: HashSet (CI ByteString) -> Bool -> RequestHeaders -> RequestHeaders
deleteHeaders headersToDelete :: HashSet (CI ByteString)
headersToDelete deleteXAccel :: Bool
deleteXAccel =
    (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
           )

-- | Translates encoded response to 'ContentHandlerResult'.
--
-- The translated data can be forwarded to the client by a simple handler based
-- on this function in directive /haskell_content/. Handlers /fromFullResponse/
-- and /fromFullResponseWithException/ forward the response to the client after
-- deleting headers listed in set 'notForwardableResponseHeaders' and headers
-- with names starting with /X-Accel-/. The two handlers differ in the response
-- composing function: the former always returns the response body of the
-- subrequest while the latter returns the error message in the response body if
-- an exception has happened during the subrequest.
contentFromFullResponse
    :: HashSet HeaderName   -- ^ Set of not forwardable response headers
    -> Bool                 -- ^ Do not forward /X-Accel-.../ response headers
    -> (L.ByteString -> ByteString -> L.ByteString)
                            -- ^ Function to compose response body and exception
    -> ByteString           -- ^ Encoded HTTP response
    -> 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'' = HashSet (CI ByteString) -> Bool -> RequestHeaders -> RequestHeaders
deleteHeaders HashSet (CI ByteString)
headersToDelete Bool
deleteXAccel 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

-- $makingBridgedHTTPSubrequests
--
-- A bridged HTTP subrequest streams the response body from the /source/ end of
-- the /bridge/ to the /sink/ end. Both source and sink are subrequests
-- configured with the familiar type /SubrequestConf/. They comprise another
-- opaque type /BridgeConf/. The bridge abstraction is useful when some data is
-- going to be copied from some source to some destination.
--
-- A bridge can be configured using handlers __/makeBridgedSubrequest/__,
-- __/makeBridgedSubrequestWithRead/__, __/makeBridgedSubrequestFull/__, and
-- __/makeBridgedSubrequestFullWithRead/__ derived from the functions with the
-- same names.
--
-- Let's extend our example with bridged subrequests.
--
-- ==== File /test_tools_extra_subrequest.hs/: auxiliary read body handler
-- @
-- reqBody :: L.ByteString -> ByteString -> IO L.ByteString
-- reqBody = const . return
--
-- 'ngxExportAsyncOnReqBody' \'reqBody
-- @
--
-- In this example, we are going to collect the request body at the sink end
-- with an auxiliary handler /reqBody/.
--
-- ==== File /nginx.conf/: upstream /sink/
-- @
--     upstream sink {
--         server 127.0.0.1:8030;
--     }
-- @
--
-- ==== File /nginx.conf/: new location /\/bridge/ in server /main/
-- @
--         location \/bridge {
--             haskell_run_async __/makeBridgedSubrequestFull/__ $hs_subrequest
--                     \'{\"__/source/__\":
--                         {\"uri\": \"http:\/\/127.0.0.1:$arg_p\/proxy\/bridge\"
--                         ,\"headers\": [[\"Custom-Header\", \"$arg_a\"]]
--                         }
--                      ,\"__/sink/__\":
--                         {\"uri\": \"http:\/\/sink_proxy\/echo\"
--                         ,\"useUDS\": true
--                         }
--                      }\';
--
--             if ($arg_exc = yes) {
--                 haskell_content __/fromFullResponseWithException/__ $hs_subrequest;
--                 break;
--             }
--
--             haskell_content __/fromFullResponse/__ $hs_subrequest;
--         }
-- @
--
-- ==== File /nginx.conf/: new location /\/bridge/ in server /backend/
-- @
--         location \/bridge {
--             set $custom_header $http_custom_header;
--             add_header Subrequest-Header \"This is response from subrequest\";
--             echo \"The response may come in chunks!\";
--             echo \"In backend, Custom-Header is \'$custom_header\'\";
--         }
-- @
--
-- ==== File /nginx.conf/: new servers /sink_proxy/ and /sink/
-- @
--     server {
--         listen       unix:\/tmp\/backend.sock;
--         server_name  sink_proxy;
--
--         location \/ {
--             proxy_pass http:\/\/sink;
--         }
--     }
--
--     server {
--         listen       8030;
--         server_name  sink;
--
--         location \/echo {
--             haskell_run_async_on_request_body reqBody $hs_rb noarg;
--             add_header Bridge-Header
--                     \"This response was bridged from subrequest\";
--             echo \"Here is the bridged response:\";
--             echo -n $hs_rb;
--         }
--     }
-- @
--
-- Upon receiving a request with URI /\/bridge/ at the main server, we are going
-- to connect to the /source/ with the same URI at the server with port equal to
-- argument /$arg_p/, and then stream its response body to a /sink/ with URI
-- /\/echo/ via proxy server /sink_proxy/. Using an internal Nginx proxy server
-- for the sink end of the bridge is necessary if the sink end does not
-- recognize chunked HTTP requests! Note also that /method/ of the sink
-- subrequest is always /POST/ independently of whether or not and how exactly
-- it was specified.
--
-- The source end puts into the bridge channel its response headers except those
-- listed in 'notForwardableResponseHeaders' and those with names starting with
-- /X-Accel-/. The request headers listed in the sink configuration get also
-- sent: their values override the values of the headers of the same names sent
-- in the response from the source end of the bridge.
--
-- Bridged HTTP subrequests have transactional semantics: any errors occurred at
-- either end of a bridge make the whole subrequest fail. Responses from the
-- source end of a bridge with /non-2xx/ status codes are regarded as a failure.
--
-- In this example, after receiving all streamed data the sink collects the
-- request body in variable /$hs_rb/ and merely sends it back as a response to
-- the original bridged subrequest. Then this response gets decoded with
-- handlers /fromFullResponse/ or /fromFullResponseWithException/ and finally
-- returned in the response to the client.
--
-- ==== A simple test
--
-- > $ curl -D- 'http://localhost:8010/bridge?a=Value&p=8010&exc=yes'
-- > HTTP/1.1 200 OK
-- > Server: nginx/1.19.4
-- > Date: Tue, 19 Oct 2021 13:12:46 GMT
-- > Content-Type: application/octet-stream
-- > Content-Length: 100
-- > Connection: keep-alive
-- > Bridge-Header: This response was bridged from subrequest
-- >
-- > Here is the bridged response:
-- > The response may come in chunks!
-- > In backend, Custom-Header is 'Value'
--
-- A negative case.
--
-- > $ curl -D- 'http://localhost:8010/bridge?a=Value&p=8021&exc=yes'
-- > HTTP/1.1 502 Bad Gateway
-- > Server: nginx/1.19.4
-- > Date: Tue, 19 Oct 2021 13:16:18 GMT
-- > Content-Length: 600
-- > Connection: keep-alive
-- >
-- > HttpExceptionRequest Request {
-- >   host                 = "127.0.0.1"
-- >   port                 = 8021
-- >   secure               = False
-- >   requestHeaders       = [("Custom-Header","Value")]
-- >   path                 = "/proxy/bridge"
-- >   queryString          = ""
-- >   method               = "GET"
-- >   proxy                = Nothing
-- >   rawBody              = False
-- >   redirectCount        = 10
-- >   responseTimeout      = ResponseTimeoutDefault
-- >   requestVersion       = HTTP/1.1
-- >   proxySecureMode      = ProxySecureWithConnect
-- > }
-- >  (ConnectionFailure Network.Socket.connect: <socket: 32>: does not exist (Connection refused))

makeStreamingRequest :: GivesPopper () -> SubrequestConf -> Request -> Request
makeStreamingRequest :: GivesPopper () -> SubrequestConf -> Request -> Request
makeStreamingRequest givesPopper :: GivesPopper ()
givesPopper conf :: SubrequestConf
conf req :: Request
req =
    SubrequestConf -> Request -> Request
makeRequest SubrequestConf
conf { srMethod :: ByteString
srMethod = "POST" , srBody :: ByteString
srBody = "" }
                Request
req { requestBody :: RequestBody
requestBody = GivesPopper () -> RequestBody
RequestBodyStreamChunked GivesPopper ()
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 parseRequestF :: String -> IO Request
parseRequestF buildResponseF :: Response ByteString -> ByteString
buildResponseF BridgeConf {..} = do
    Manager
manIn <- if SubrequestConf -> Bool
srUseUDS SubrequestConf
bridgeSource
                 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
    Manager
manOut <- if SubrequestConf -> Bool
srUseUDS SubrequestConf
bridgeSink
                  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
    -- BEWARE: a non-2xx response from the bridge source will throw
    -- StatusCodeException with this status which finally will be returned as
    -- the status code of the whole bridged subrequest
    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
$ \respIn :: Response (IO ByteString)
respIn -> do
        let reqOut' :: Request
reqOut' = Request
reqOut { requestHeaders :: RequestHeaders
requestHeaders =
                                   HashSet (CI ByteString) -> Bool -> RequestHeaders -> RequestHeaders
deleteHeaders
                                       HashSet (CI ByteString)
notForwardableResponseHeaders
                                       Bool
True (Response (IO ByteString) -> RequestHeaders
forall body. Response body -> RequestHeaders
responseHeaders Response (IO ByteString)
respIn)
                             }
            givesPopper :: (IO ByteString -> t) -> t
givesPopper needsPopper :: IO ByteString -> t
needsPopper = IO ByteString -> t
needsPopper (IO ByteString -> t) -> IO ByteString -> t
forall a b. (a -> b) -> a -> b
$ IO ByteString -> IO ByteString
brRead (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)
httpLbs (GivesPopper () -> SubrequestConf -> Request -> Request
makeStreamingRequest GivesPopper ()
forall t. (IO ByteString -> t) -> t
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

-- | Makes a bridged HTTP request.
--
-- This is the core function of the /makeBridgedSubrequest/ handler. From
-- perspective of an Nginx request, it spawns two subrequests connecting the two
-- ends of a /bridge/: the /source/ and the /sink/, hence the name.
--
-- Accepts a JSON object representing an opaque type /BridgeConf/ with mandatory
-- fields /source/ and /sink/.
--
-- An example of a bridge configuration:
--
-- > {"source":
-- >      {"uri": "http://example.com/"
-- >      ,"headers": [["Header1", "Value1"], ["Header2", "Value2"]]
-- >      }
-- > ,"sink":
-- >      {"uri": "http://sink_proxy/"
-- >      ,"useUDS": true
-- >      }
-- > }
--
-- The sink method is always /POST/ while its body is always empty independently
-- of whether or not and how exactly they were specified.
--
-- Returns the response body of the sink if HTTP status of the response is
-- /2xx/, otherwise throws an error. To avoid leakage of error messages into
-- variable handlers, put the corresponding variables into the list of directive
-- /haskell_var_empty_on_error/.
makeBridgedSubrequest
    :: ByteString       -- ^ Bridge configuration
    -> 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
.
        FromJSON BridgeConf => ByteString -> Maybe BridgeConf
forall a. FromJSON a => ByteString -> Maybe a
readFromByteStringAsJSON @BridgeConf

ngxExportAsyncIOYY 'makeBridgedSubrequest

-- | Makes a bridged HTTP request.
--
-- Behaves exactly as 'makeBridgedSubrequest' except it parses Haskell terms
-- representing /BridgeConf/ with 'read'. Exported on the Nginx level by
-- handler /makeBridgedSubrequestWithRead/.
--
-- An example of a bridge configuration:
--
-- > BridgeConf
-- > { bridgeSource = SubrequestConf
-- >       { srMethod = ""
-- >       , srUri = "http://127.0.0.1/source"
-- >       , srBody = ""
-- >       , srHeaders = [("Header1", "Value1"), ("Header2", "Value2")]
-- >       , srResponseTimeout = ResponseTimeout (Sec 10)
-- >       , srUseUDS = False
-- >       }
-- > , bridgeSink = SubrequestConf
-- >       { srMethod = ""
-- >       , srUri = "http://127.0.0.1/sink"
-- >       , srBody = ""
-- >       , srHeaders = []
-- >       , srResponseTimeout = ResponseTimeout (Sec 10)
-- >       , srUseUDS = False
-- >       }
-- > }
--
-- The sink method is always /POST/ while its body is always empty independently
-- of how exactly they were specified.
--
-- Notice that unlike JSON parsing, fields of /SubrequestConf/ comprising
-- /bridgeSource/ and /bridgeSink/ are not omittable and must be listed in the
-- order shown in the example. As well, fields /bridgeSource/ and /bridgeSink/
-- must be listed in this order.
makeBridgedSubrequestWithRead
    :: ByteString       -- ^ Bridge configuration
    -> 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
.
        Read BridgeConf => ByteString -> Maybe BridgeConf
forall a. Read a => ByteString -> Maybe a
readFromByteString @BridgeConf

ngxExportAsyncIOYY 'makeBridgedSubrequestWithRead

-- | Makes a bridged HTTP request.
--
-- The same as 'makeBridgedSubrequest' except it returns a binary encoded
-- response data whose parts must be extracted by handlers made of
-- 'extractStatusFromFullResponse', 'extractHeaderFromFullResponse',
-- 'extractBodyFromFullResponse', and 'extractExceptionFromFullResponse'. It
-- does not throw any exceptions outside. Exported on the Nginx level by handler
-- /makeBridgedSubrequestFull/.
makeBridgedSubrequestFull
    :: ByteString       -- ^ Bridge configuration
    -> 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 (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 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
. FromJSON BridgeConf => ByteString -> Maybe BridgeConf
forall a. FromJSON a => ByteString -> Maybe a
readFromByteStringAsJSON @BridgeConf

ngxExportAsyncIOYY 'makeBridgedSubrequestFull

-- | Makes a bridged HTTP request.
--
-- The same as 'makeBridgedSubrequestWithRead' except it returns a binary
-- encoded response data whose parts must be extracted by handlers made of
-- 'extractStatusFromFullResponse', 'extractHeaderFromFullResponse',
-- 'extractBodyFromFullResponse', and 'extractExceptionFromFullResponse'. It
-- does not throw any exceptions outside. Exported on the Nginx level by handler
-- /makeBridgedSubrequestFullWithRead/.
makeBridgedSubrequestFullWithRead
    :: ByteString       -- ^ Bridge configuration
    -> 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 (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 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
. Read BridgeConf => ByteString -> Maybe BridgeConf
forall a. Read a => ByteString -> Maybe a
readFromByteString @BridgeConf

ngxExportAsyncIOYY 'makeBridgedSubrequestFullWithRead