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

-----------------------------------------------------------------------------
-- |
-- Module      :  NgxExport.Tools.Subrequest
-- Copyright   :  (c) Alexey Radkov 2020-2024
-- License     :  BSD-style
--
-- Maintainer  :  alexey.radkov@gmail.com
-- Stability   :  stable
-- Portability :  non-portable (requires Template Haskell)
--
-- Easy HTTP subrequests from the more extra tools collection for
-- <https://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

    -- * HTTP subrequests with a custom HTTP manager
    -- $subrequestsWithCustomManager
                                  ,registerCustomManager
    -- * 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.Read
import           NgxExport.Tools.Combinators
import           NgxExport.Tools.SimpleService
import           NgxExport.Tools.TimeInterval

import           Network.HTTP.Client hiding (ResponseTimeout)
import qualified Network.HTTP.Client (HttpExceptionContent (ResponseTimeout))
import           Network.HTTP.Client.TLS (newTlsManager)
import           Network.HTTP.Client.BrReadWithTimeout
import           Network.HTTP.Types
import qualified Network.Socket as S
import qualified Network.Socket.ByteString as SB
import           Data.ByteString (ByteString)
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as C8
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Lazy.Char8 as C8L
import           Data.IORef
import qualified Data.Text.Encoding as T
import qualified Data.Text.Lazy.Encoding as TL
import qualified Data.Binary as Binary
import qualified Data.HashMap.Strict as HM
import           Data.HashMap.Strict (HashMap)
import           Data.HashSet (HashSet)
import qualified Data.HashSet as HS
import           Data.CaseInsensitive hiding (map)
import           Data.Function
import           Data.Aeson
import           Data.Maybe
import           Data.List
import           Control.Arrow
import           Control.Exception
import           System.IO.Unsafe

-- $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 -> 'NgxExportService'
-- __/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\": \"https:\/\/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
$cshowsPrec :: Int -> SubrequestParseError -> ShowS
showsPrec :: Int -> SubrequestParseError -> ShowS
$cshow :: SubrequestParseError -> String
show :: SubrequestParseError -> String
$cshowList :: [SubrequestParseError] -> ShowS
showList :: [SubrequestParseError] -> ShowS
Show

instance Exception SubrequestParseError

data BridgeParseError = BridgeParseError deriving Int -> BridgeParseError -> ShowS
[BridgeParseError] -> ShowS
BridgeParseError -> String
(Int -> BridgeParseError -> ShowS)
-> (BridgeParseError -> String)
-> ([BridgeParseError] -> ShowS)
-> Show BridgeParseError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BridgeParseError -> ShowS
showsPrec :: Int -> BridgeParseError -> ShowS
$cshow :: BridgeParseError -> String
show :: BridgeParseError -> String
$cshowList :: [BridgeParseError] -> ShowS
showList :: [BridgeParseError] -> ShowS
Show

instance Exception BridgeParseError

data UDSNotConfiguredError = UDSNotConfiguredError deriving Int -> UDSNotConfiguredError -> ShowS
[UDSNotConfiguredError] -> ShowS
UDSNotConfiguredError -> String
(Int -> UDSNotConfiguredError -> ShowS)
-> (UDSNotConfiguredError -> String)
-> ([UDSNotConfiguredError] -> ShowS)
-> Show UDSNotConfiguredError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> UDSNotConfiguredError -> ShowS
showsPrec :: Int -> UDSNotConfiguredError -> ShowS
$cshow :: UDSNotConfiguredError -> String
show :: UDSNotConfiguredError -> String
$cshowList :: [UDSNotConfiguredError] -> ShowS
showList :: [UDSNotConfiguredError] -> ShowS
Show

instance Exception UDSNotConfiguredError

newtype ManagerNotConfiguredError =
    ManagerNotConfiguredError ByteString deriving Int -> ManagerNotConfiguredError -> ShowS
[ManagerNotConfiguredError] -> ShowS
ManagerNotConfiguredError -> String
(Int -> ManagerNotConfiguredError -> ShowS)
-> (ManagerNotConfiguredError -> String)
-> ([ManagerNotConfiguredError] -> ShowS)
-> Show ManagerNotConfiguredError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ManagerNotConfiguredError -> ShowS
showsPrec :: Int -> ManagerNotConfiguredError -> ShowS
$cshow :: ManagerNotConfiguredError -> String
show :: ManagerNotConfiguredError -> String
$cshowList :: [ManagerNotConfiguredError] -> ShowS
showList :: [ManagerNotConfiguredError] -> ShowS
Show

instance Exception ManagerNotConfiguredError

data ResponseTimeout = ResponseTimeoutDefault
                     | ResponseTimeout TimeInterval deriving (ResponseTimeout -> ResponseTimeout -> Bool
(ResponseTimeout -> ResponseTimeout -> Bool)
-> (ResponseTimeout -> ResponseTimeout -> Bool)
-> Eq ResponseTimeout
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ResponseTimeout -> ResponseTimeout -> Bool
== :: ResponseTimeout -> ResponseTimeout -> Bool
$c/= :: ResponseTimeout -> ResponseTimeout -> Bool
/= :: ResponseTimeout -> ResponseTimeout -> Bool
Eq, ReadPrec [ResponseTimeout]
ReadPrec ResponseTimeout
Int -> ReadS ResponseTimeout
ReadS [ResponseTimeout]
(Int -> ReadS ResponseTimeout)
-> ReadS [ResponseTimeout]
-> ReadPrec ResponseTimeout
-> ReadPrec [ResponseTimeout]
-> Read ResponseTimeout
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS ResponseTimeout
readsPrec :: Int -> ReadS ResponseTimeout
$creadList :: ReadS [ResponseTimeout]
readList :: ReadS [ResponseTimeout]
$creadPrec :: ReadPrec ResponseTimeout
readPrec :: ReadPrec ResponseTimeout
$creadListPrec :: ReadPrec [ResponseTimeout]
readListPrec :: ReadPrec [ResponseTimeout]
Read)

data ConnectionManager = Default
                       | UDS
                       | Custom ByteString deriving (ConnectionManager -> ConnectionManager -> Bool
(ConnectionManager -> ConnectionManager -> Bool)
-> (ConnectionManager -> ConnectionManager -> Bool)
-> Eq ConnectionManager
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ConnectionManager -> ConnectionManager -> Bool
== :: ConnectionManager -> ConnectionManager -> Bool
$c/= :: ConnectionManager -> ConnectionManager -> Bool
/= :: ConnectionManager -> ConnectionManager -> Bool
Eq, ReadPrec [ConnectionManager]
ReadPrec ConnectionManager
Int -> ReadS ConnectionManager
ReadS [ConnectionManager]
(Int -> ReadS ConnectionManager)
-> ReadS [ConnectionManager]
-> ReadPrec ConnectionManager
-> ReadPrec [ConnectionManager]
-> Read ConnectionManager
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS ConnectionManager
readsPrec :: Int -> ReadS ConnectionManager
$creadList :: ReadS [ConnectionManager]
readList :: ReadS [ConnectionManager]
$creadPrec :: ReadPrec ConnectionManager
readPrec :: ReadPrec ConnectionManager
$creadListPrec :: ReadPrec [ConnectionManager]
readListPrec :: ReadPrec [ConnectionManager]
Read)

data SubrequestConf =
    SubrequestConf { SubrequestConf -> ByteString
srMethod          :: ByteString
                   , SubrequestConf -> String
srUri             :: String
                   , SubrequestConf -> ByteString
srBody            :: L.ByteString
                   , SubrequestConf -> RequestHeaders
srHeaders         :: RequestHeaders
                   , SubrequestConf -> ResponseTimeout
srResponseTimeout :: ResponseTimeout
                   , SubrequestConf -> ConnectionManager
srManager         :: ConnectionManager
                   } deriving ReadPrec [SubrequestConf]
ReadPrec SubrequestConf
Int -> ReadS SubrequestConf
ReadS [SubrequestConf]
(Int -> ReadS SubrequestConf)
-> ReadS [SubrequestConf]
-> ReadPrec SubrequestConf
-> ReadPrec [SubrequestConf]
-> Read SubrequestConf
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS SubrequestConf
readsPrec :: Int -> ReadS SubrequestConf
$creadList :: ReadS [SubrequestConf]
readList :: ReadS [SubrequestConf]
$creadPrec :: ReadPrec SubrequestConf
readPrec :: ReadPrec SubrequestConf
$creadListPrec :: ReadPrec [SubrequestConf]
readListPrec :: ReadPrec [SubrequestConf]
Read

instance FromJSON SubrequestConf where
    parseJSON :: Value -> Parser SubrequestConf
parseJSON = String
-> (Object -> Parser SubrequestConf)
-> Value
-> Parser SubrequestConf
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"SubrequestConf" ((Object -> Parser SubrequestConf)
 -> Value -> Parser SubrequestConf)
-> (Object -> Parser SubrequestConf)
-> Value
-> Parser SubrequestConf
forall a b. (a -> b) -> a -> b
$ \Object
o -> do
        ByteString
srMethod <- ByteString -> (Text -> ByteString) -> Maybe Text -> ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString
"" Text -> ByteString
T.encodeUtf8 (Maybe Text -> ByteString)
-> Parser (Maybe Text) -> Parser ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"method"
        String
srUri <- Object
o Object -> Key -> Parser String
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"uri"
        ByteString
srBody <- ByteString -> (Text -> ByteString) -> Maybe Text -> ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString
"" Text -> ByteString
TL.encodeUtf8 (Maybe Text -> ByteString)
-> Parser (Maybe Text) -> Parser ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"body"
        RequestHeaders
srHeaders <- ((Text, Text) -> (HeaderName, ByteString))
-> [(Text, Text)] -> RequestHeaders
forall a b. (a -> b) -> [a] -> [b]
map (ByteString -> HeaderName
forall s. FoldCase s => s -> CI s
mk (ByteString -> HeaderName)
-> (Text -> ByteString) -> Text -> HeaderName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
T.encodeUtf8 (Text -> HeaderName)
-> (Text -> ByteString) -> (Text, Text) -> (HeaderName, ByteString)
forall b c b' c'. (b -> c) -> (b' -> c') -> (b, b') -> (c, c')
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** Text -> ByteString
T.encodeUtf8) ([(Text, Text)] -> RequestHeaders)
-> Parser [(Text, Text)] -> Parser RequestHeaders
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
            Object
o Object -> Key -> Parser (Maybe [(Text, Text)])
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"headers" Parser (Maybe [(Text, Text)])
-> [(Text, Text)] -> Parser [(Text, Text)]
forall a. Parser (Maybe a) -> a -> Parser a
.!= []
        ResponseTimeout
srResponseTimeout <- ResponseTimeout
-> (TimeInterval -> ResponseTimeout)
-> Maybe TimeInterval
-> ResponseTimeout
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ResponseTimeout
ResponseTimeoutDefault TimeInterval -> ResponseTimeout
ResponseTimeout (Maybe TimeInterval -> ResponseTimeout)
-> Parser (Maybe TimeInterval) -> Parser ResponseTimeout
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
            Object
o Object -> Key -> Parser (Maybe TimeInterval)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"timeout"
        ConnectionManager
srManager <- ConnectionManager
-> (Text -> ConnectionManager) -> Maybe Text -> ConnectionManager
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ConnectionManager
Default (\case
                                        Text
"default" -> ConnectionManager
Default
                                        Text
"uds" -> ConnectionManager
UDS
                                        Text
v -> ByteString -> ConnectionManager
Custom (ByteString -> ConnectionManager)
-> ByteString -> ConnectionManager
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
T.encodeUtf8 Text
v
                                   ) (Maybe Text -> ConnectionManager)
-> Parser (Maybe Text) -> Parser ConnectionManager
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"manager"
        SubrequestConf -> Parser SubrequestConf
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return SubrequestConf {String
RequestHeaders
ByteString
ByteString
ConnectionManager
ResponseTimeout
srMethod :: ByteString
srUri :: String
srBody :: ByteString
srHeaders :: RequestHeaders
srResponseTimeout :: ResponseTimeout
srManager :: ConnectionManager
srMethod :: ByteString
srUri :: String
srBody :: ByteString
srHeaders :: RequestHeaders
srResponseTimeout :: ResponseTimeout
srManager :: ConnectionManager
..}

data BridgeConf = BridgeConf { BridgeConf -> SubrequestConf
bridgeSource :: SubrequestConf
                             , BridgeConf -> SubrequestConf
bridgeSink :: SubrequestConf
                             } deriving ReadPrec [BridgeConf]
ReadPrec BridgeConf
Int -> ReadS BridgeConf
ReadS [BridgeConf]
(Int -> ReadS BridgeConf)
-> ReadS [BridgeConf]
-> ReadPrec BridgeConf
-> ReadPrec [BridgeConf]
-> Read BridgeConf
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS BridgeConf
readsPrec :: Int -> ReadS BridgeConf
$creadList :: ReadS [BridgeConf]
readList :: ReadS [BridgeConf]
$creadPrec :: ReadPrec BridgeConf
readPrec :: ReadPrec BridgeConf
$creadListPrec :: ReadPrec [BridgeConf]
readListPrec :: ReadPrec [BridgeConf]
Read

instance FromJSON BridgeConf where
    parseJSON :: Value -> Parser BridgeConf
parseJSON = String
-> (Object -> Parser BridgeConf) -> Value -> Parser BridgeConf
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"BridgeConf" ((Object -> Parser BridgeConf) -> Value -> Parser BridgeConf)
-> (Object -> Parser BridgeConf) -> Value -> Parser BridgeConf
forall a b. (a -> b) -> a -> b
$ \Object
o -> do
        SubrequestConf
bridgeSource <- Object
o Object -> Key -> Parser SubrequestConf
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"source"
        SubrequestConf
bridgeSink <- Object
o Object -> Key -> Parser SubrequestConf
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"sink"
        BridgeConf -> Parser BridgeConf
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return BridgeConf {SubrequestConf
bridgeSource :: SubrequestConf
bridgeSink :: SubrequestConf
bridgeSource :: SubrequestConf
bridgeSink :: SubrequestConf
..}

makeRequest :: SubrequestConf -> Request -> Request
makeRequest :: SubrequestConf -> Request -> Request
makeRequest SubrequestConf {String
RequestHeaders
ByteString
ByteString
ConnectionManager
ResponseTimeout
srMethod :: SubrequestConf -> ByteString
srUri :: SubrequestConf -> String
srBody :: SubrequestConf -> ByteString
srHeaders :: SubrequestConf -> RequestHeaders
srResponseTimeout :: SubrequestConf -> ResponseTimeout
srManager :: SubrequestConf -> ConnectionManager
srMethod :: ByteString
srUri :: String
srBody :: ByteString
srHeaders :: RequestHeaders
srResponseTimeout :: ResponseTimeout
srManager :: ConnectionManager
..} Request
req =
    Request
req { method = if B.null srMethod
                       then method req
                       else srMethod
        , requestBody = if L.null srBody
                            then requestBody req
                            else RequestBodyLBS srBody
        , requestHeaders = unionBy ((==) `on` fst) srHeaders $
                               requestHeaders req
        , responseTimeout = if srResponseTimeout == ResponseTimeoutDefault
                                then responseTimeout req
                                else setTimeout srResponseTimeout
        }
    where setTimeout :: ResponseTimeout -> ResponseTimeout
setTimeout (ResponseTimeout TimeInterval
v)
              | Int
t Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = ResponseTimeout
responseTimeoutNone
              | Bool
otherwise = Int -> ResponseTimeout
responseTimeoutMicro (Int -> ResponseTimeout) -> Int -> ResponseTimeout
forall a b. (a -> b) -> a -> b
$ Int
t Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1e6
              where t :: Int
t = TimeInterval -> Int
toSec TimeInterval
v
          setTimeout ResponseTimeout
_ = ResponseTimeout
forall a. HasCallStack => a
undefined

subrequest :: (String -> IO Request) ->
    (Response L.ByteString -> L.ByteString) -> SubrequestConf ->
    IO L.ByteString
subrequest :: (String -> IO Request)
-> (Response ByteString -> ByteString)
-> SubrequestConf
-> IO ByteString
subrequest String -> IO Request
parseRequestF Response ByteString -> ByteString
buildResponseF sub :: SubrequestConf
sub@SubrequestConf {String
RequestHeaders
ByteString
ByteString
ConnectionManager
ResponseTimeout
srMethod :: SubrequestConf -> ByteString
srUri :: SubrequestConf -> String
srBody :: SubrequestConf -> ByteString
srHeaders :: SubrequestConf -> RequestHeaders
srResponseTimeout :: SubrequestConf -> ResponseTimeout
srManager :: SubrequestConf -> ConnectionManager
srMethod :: ByteString
srUri :: String
srBody :: ByteString
srHeaders :: RequestHeaders
srResponseTimeout :: ResponseTimeout
srManager :: ConnectionManager
..} = do
    Manager
man <- SubrequestConf -> IO Manager
getManager SubrequestConf
sub
    Request
req <- String -> IO Request
parseRequestF String
srUri
    Response ByteString -> ByteString
buildResponseF (Response ByteString -> ByteString)
-> IO (Response ByteString) -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Request -> Manager -> IO (Response ByteString)
httpLbsBrReadWithTimeout (SubrequestConf -> Request -> Request
makeRequest SubrequestConf
sub Request
req) Manager
man

subrequestBody :: SubrequestConf -> IO L.ByteString
subrequestBody :: SubrequestConf -> IO ByteString
subrequestBody = (String -> IO Request)
-> (Response ByteString -> ByteString)
-> SubrequestConf
-> IO ByteString
subrequest String -> IO Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseUrlThrow Response ByteString -> ByteString
forall body. Response body -> body
responseBody

type FullResponse = (Int, [(ByteString, ByteString)], L.ByteString, ByteString)

handleFullResponse :: IO L.ByteString -> IO L.ByteString
handleFullResponse :: IO ByteString -> IO ByteString
handleFullResponse = (SomeException -> IO ByteString) -> IO ByteString -> IO ByteString
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle ((SomeException -> IO ByteString)
 -> IO ByteString -> IO ByteString)
-> (SomeException -> IO ByteString)
-> IO ByteString
-> IO ByteString
forall a b. (a -> b) -> a -> b
$ \SomeException
e -> do
    let msg :: ByteString
msg = String -> ByteString
C8.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ SomeException -> String
forall a. Show a => a -> String
show SomeException
e
        responseXXX :: t -> (t, [a], ByteString, ByteString)
responseXXX = (, [], ByteString
"", ByteString
msg)
        response500 :: (Int, [a], ByteString, ByteString)
response500 = Int -> (Int, [a], ByteString, ByteString)
forall {t} {a}. t -> (t, [a], ByteString, ByteString)
responseXXX Int
500
        response502 :: (Int, [a], ByteString, ByteString)
response502 = Int -> (Int, [a], ByteString, ByteString)
forall {t} {a}. t -> (t, [a], ByteString, ByteString)
responseXXX Int
502
    ByteString -> IO ByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ forall a. Binary a => a -> ByteString
Binary.encode @FullResponse (FullResponse -> ByteString) -> FullResponse -> ByteString
forall a b. (a -> b) -> a -> b
$
        case SomeException -> Maybe HttpException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e of
            Just (HttpExceptionRequest Request
_ HttpExceptionContent
c) ->
                case HttpExceptionContent
c of
                    HttpExceptionContent
Network.HTTP.Client.ResponseTimeout -> FullResponse
forall {a}. (Int, [a], ByteString, ByteString)
response502
                    HttpExceptionContent
ConnectionTimeout -> FullResponse
forall {a}. (Int, [a], ByteString, ByteString)
response502
                    ConnectionFailure SomeException
_ -> FullResponse
forall {a}. (Int, [a], ByteString, ByteString)
response502
                    StatusCodeException Response ()
r ByteString
_ ->
                        let status :: Int
status = Status -> Int
statusCode (Status -> Int) -> Status -> Int
forall a b. (a -> b) -> a -> b
$ Response () -> Status
forall body. Response body -> Status
responseStatus Response ()
r
                        in Int -> FullResponse
forall {t} {a}. t -> (t, [a], ByteString, ByteString)
responseXXX Int
status
                    HttpExceptionContent
_ -> FullResponse
forall {a}. (Int, [a], ByteString, ByteString)
response500
            Maybe HttpException
_ -> FullResponse
forall {a}. (Int, [a], ByteString, ByteString)
response500

buildFullResponse :: Response L.ByteString -> L.ByteString
buildFullResponse :: Response ByteString -> ByteString
buildFullResponse Response ByteString
r =
    let status :: Int
status = Status -> Int
statusCode (Status -> Int) -> Status -> Int
forall a b. (a -> b) -> a -> b
$ Response ByteString -> Status
forall body. Response body -> Status
responseStatus Response ByteString
r
        headers :: [(ByteString, ByteString)]
headers = ((HeaderName, ByteString) -> (ByteString, ByteString))
-> RequestHeaders -> [(ByteString, ByteString)]
forall a b. (a -> b) -> [a] -> [b]
map ((HeaderName -> ByteString)
-> (HeaderName, ByteString) -> (ByteString, ByteString)
forall b c d. (b -> c) -> (b, d) -> (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first HeaderName -> ByteString
forall s. CI s -> s
original) (RequestHeaders -> [(ByteString, ByteString)])
-> RequestHeaders -> [(ByteString, ByteString)]
forall a b. (a -> b) -> a -> b
$ Response ByteString -> RequestHeaders
forall body. Response body -> RequestHeaders
responseHeaders Response ByteString
r
        body :: ByteString
body = Response ByteString -> ByteString
forall body. Response body -> body
responseBody Response ByteString
r
    in forall a. Binary a => a -> ByteString
Binary.encode @FullResponse (Int
status, [(ByteString, ByteString)]
headers, ByteString
body, ByteString
"")

subrequestFull :: SubrequestConf -> IO L.ByteString
subrequestFull :: SubrequestConf -> IO ByteString
subrequestFull = IO ByteString -> IO ByteString
handleFullResponse (IO ByteString -> IO ByteString)
-> (SubrequestConf -> IO ByteString)
-> SubrequestConf
-> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> IO Request)
-> (Response ByteString -> ByteString)
-> SubrequestConf
-> IO ByteString
subrequest String -> IO Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseRequest Response ByteString -> ByteString
buildFullResponse

httpManager :: Manager
httpManager :: Manager
httpManager = IO Manager -> Manager
forall a. IO a -> a
unsafePerformIO IO Manager
forall (m :: * -> *). MonadIO m => m Manager
newTlsManager
{-# NOINLINE httpManager #-}

httpUDSManager :: IORef (Maybe Manager)
httpUDSManager :: IORef (Maybe Manager)
httpUDSManager = IO (IORef (Maybe Manager)) -> IORef (Maybe Manager)
forall a. IO a -> a
unsafePerformIO (IO (IORef (Maybe Manager)) -> IORef (Maybe Manager))
-> IO (IORef (Maybe Manager)) -> IORef (Maybe Manager)
forall a b. (a -> b) -> a -> b
$ Maybe Manager -> IO (IORef (Maybe Manager))
forall a. a -> IO (IORef a)
newIORef Maybe Manager
forall a. Maybe a
Nothing
{-# NOINLINE httpUDSManager #-}

httpCustomManager :: IORef (HashMap ByteString Manager)
httpCustomManager :: IORef (HashMap ByteString Manager)
httpCustomManager = IO (IORef (HashMap ByteString Manager))
-> IORef (HashMap ByteString Manager)
forall a. IO a -> a
unsafePerformIO (IO (IORef (HashMap ByteString Manager))
 -> IORef (HashMap ByteString Manager))
-> IO (IORef (HashMap ByteString Manager))
-> IORef (HashMap ByteString Manager)
forall a b. (a -> b) -> a -> b
$ HashMap ByteString Manager
-> IO (IORef (HashMap ByteString Manager))
forall a. a -> IO (IORef a)
newIORef HashMap ByteString Manager
forall k v. HashMap k v
HM.empty
{-# NOINLINE httpCustomManager #-}

getManager :: SubrequestConf -> IO Manager
getManager :: SubrequestConf -> IO Manager
getManager SubrequestConf {String
RequestHeaders
ByteString
ByteString
ConnectionManager
ResponseTimeout
srMethod :: SubrequestConf -> ByteString
srUri :: SubrequestConf -> String
srBody :: SubrequestConf -> ByteString
srHeaders :: SubrequestConf -> RequestHeaders
srResponseTimeout :: SubrequestConf -> ResponseTimeout
srManager :: SubrequestConf -> ConnectionManager
srMethod :: ByteString
srUri :: String
srBody :: ByteString
srHeaders :: RequestHeaders
srResponseTimeout :: ResponseTimeout
srManager :: ConnectionManager
..} =
    case ConnectionManager
srManager of
        ConnectionManager
Default ->
            Manager -> IO Manager
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Manager
httpManager
        ConnectionManager
UDS ->
            Manager -> Maybe Manager -> Manager
forall a. a -> Maybe a -> a
fromMaybe (UDSNotConfiguredError -> Manager
forall a e. Exception e => e -> a
throw UDSNotConfiguredError
UDSNotConfiguredError) (Maybe Manager -> Manager) -> IO (Maybe Manager) -> IO Manager
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                IORef (Maybe Manager) -> IO (Maybe Manager)
forall a. IORef a -> IO a
readIORef IORef (Maybe Manager)
httpUDSManager
        Custom ByteString
k ->
            Manager -> Maybe Manager -> Manager
forall a. a -> Maybe a -> a
fromMaybe (ManagerNotConfiguredError -> Manager
forall a e. Exception e => e -> a
throw (ManagerNotConfiguredError -> Manager)
-> ManagerNotConfiguredError -> Manager
forall a b. (a -> b) -> a -> b
$ ByteString -> ManagerNotConfiguredError
ManagerNotConfiguredError ByteString
k) (Maybe Manager -> Manager)
-> (HashMap ByteString Manager -> Maybe Manager)
-> HashMap ByteString Manager
-> Manager
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> HashMap ByteString Manager -> Maybe Manager
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup ByteString
k (HashMap ByteString Manager -> Manager)
-> IO (HashMap ByteString Manager) -> IO Manager
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                IORef (HashMap ByteString Manager)
-> IO (HashMap ByteString Manager)
forall a. IORef a -> IO a
readIORef IORef (HashMap ByteString Manager)
httpCustomManager

-- | 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 the following fields: /method/ (optional, default is
-- /GET/), /uri/ (mandatory), /body/ (optional, default is an empty string),
-- /headers/ (optional, default is an empty list), /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), and /manager/ (an optional value which links to an HTTP manager
-- that will serve connections, default is /default/ which links to the internal
-- TLS-aware manager).
--
-- 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"]]
-- > }
--
-- Note that the response timeout is in effect until receiving the response
-- headers as well as in between the successive body read events.
--
-- 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
.
        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)
-- >                , srManager = Default
-- >                }
--
-- 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/. Values of /srManager/ can be /Default/, /UDS/, or
-- /Custom \"key\"/ where /key/ is an arbitrary key bound to a custom HTTP
-- manager.
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
.
        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
-- setting field /manager/ to value /uds/ in the subrequest configuration.
--
-- 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\"]]
--                      ,\"__/manager/__\": \"__uds__\"
--                      }\';
--
--             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
$creadsPrec :: Int -> ReadS UDSConf
readsPrec :: Int -> ReadS UDSConf
$creadList :: ReadS [UDSConf]
readList :: ReadS [UDSConf]
$creadPrec :: ReadPrec UDSConf
readPrec :: ReadPrec UDSConf
$creadListPrec :: ReadPrec [UDSConf]
readListPrec :: ReadPrec [UDSConf]
Read

configureUDS :: UDSConf -> NgxExportService
configureUDS :: UDSConf -> Bool -> IO ByteString
configureUDS = (UDSConf -> IO ByteString) -> UDSConf -> Bool -> IO ByteString
forall a. (a -> IO ByteString) -> a -> Bool -> IO ByteString
ignitionService ((UDSConf -> IO ByteString) -> UDSConf -> Bool -> IO ByteString)
-> (UDSConf -> IO ByteString) -> UDSConf -> Bool -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \UDSConf {String
udsPath :: UDSConf -> String
udsPath :: String
..} -> IO () -> IO ByteString
forall a. IO a -> IO ByteString
voidHandler (IO () -> IO ByteString) -> IO () -> IO ByteString
forall a b. (a -> b) -> a -> b
$ do
    Manager
man <- ManagerSettings -> IO Manager
newManager ManagerSettings
defaultManagerSettings
               { managerRawConnection = return $ openUDS udsPath }
    IORef (Maybe Manager) -> Maybe Manager -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe Manager)
httpUDSManager (Maybe Manager -> IO ()) -> Maybe Manager -> IO ()
forall a b. (a -> b) -> a -> b
$ Manager -> Maybe Manager
forall a. a -> Maybe a
Just Manager
man
    where openUDS :: String -> p -> p -> p -> IO Connection
openUDS String
path p
_ p
_ p
_ = do
              Socket
s <- Family -> SocketType -> CInt -> IO Socket
S.socket Family
S.AF_UNIX SocketType
S.Stream CInt
S.defaultProtocol
              Socket -> SockAddr -> IO ()
S.connect Socket
s (String -> SockAddr
S.SockAddrUnix String
path)
              IO ByteString -> (ByteString -> IO ()) -> IO () -> IO Connection
makeConnection (Socket -> Int -> IO ByteString
SB.recv Socket
s Int
4096) (Socket -> ByteString -> IO ()
SB.sendAll Socket
s) (Socket -> IO ()
S.close Socket
s)

ngxExportSimpleServiceTyped 'configureUDS ''UDSConf SingleShotService

-- $subrequestsWithCustomManager
--
-- To serve subrequests, a custom HTTP manager can be implemented and then
-- registered in a custom service handler with 'registerCustomManager'. To
-- enable this manager in a subrequest configuration, use field /manager/
-- with the key that was bound to the manager in 'registerCustomManager'.
--
-- For example, let's implement a custom UDS manager which will serve
-- connections via Unix Domain Sockets as in the previous section.
--
-- ==== File /test_tools_extra_subrequest_custom_manager.hs/
-- @
-- {-\# LANGUAGE TemplateHaskell, OverloadedStrings \#-}
--
-- module TestToolsExtraSubrequestCustomManager where
--
-- import           NgxExport.Tools
-- import           NgxExport.Tools.Subrequest
--
-- import           Data.ByteString (ByteString)
-- import qualified Data.ByteString.Lazy as L
--
-- import           Network.HTTP.Client
-- import qualified Network.Socket as S
-- import qualified Network.Socket.ByteString as SB
-- import qualified Data.ByteString.Char8 as C8
--
-- configureUdsManager :: ByteString -> 'NgxExportService'
-- __/configureUdsManager/__ = 'ignitionService' $ \\path -> 'voidHandler' $ do
--     man <- newManager defaultManagerSettings
--                { managerRawConnection = return $ openUDS path }
--     'registerCustomManager' \"__myuds__\" man
--     where openUDS path _ _ _ = do
--               s <- S.socket S.AF_UNIX S.Stream S.defaultProtocol
--               S.connect s (S.SockAddrUnix $ C8.unpack path)
--               makeConnection (SB.recv s 4096) (SB.sendAll s) (S.close s)
--
-- 'ngxExportSimpleService' \'configureUdsManager 'SingleShotService'
-- @
--
-- ==== File /nginx.conf/: configuring the custom manager
-- @
--     haskell_run_service __/simpleService_configureUdsManager/__ $hs_service_myuds
--             \'\/tmp\/myuds.sock\';
-- @
--
-- ==== File /nginx.conf/: new location /\/myuds/ in server /main/
-- @
--         location \/myuds {
--             haskell_run_async __/makeSubrequest/__ $hs_subrequest
--                     \'{\"uri\": \"http:\/\/backend_proxy_myuds\/\"
--                      ,\"headers\": [[\"Custom-Header\", \"$arg_a\"]]
--                      ,\"__/manager/__\": \"__myuds__\"
--                      }\';
--
--             if ($hs_subrequest = \'\') {
--                 echo_status 404;
--                 echo \"Failed to perform subrequest\";
--                 break;
--             }
--
--             echo -n $hs_subrequest;
--         }
-- @
--
-- ==== File /nginx.conf/: new virtual server /backend_proxy_myuds/
-- @
--     server {
--         listen       unix:\/tmp\/myuds.sock;
--         server_name  backend_proxy_myuds;
--
--         location \/ {
--             proxy_pass http:\/\/backend;
--         }
--     }
-- @

-- | Registers a custom HTTP manager with a given key.
--
-- The right place to register a custom manager is a custom service handler or
-- the initialization hook (see 'ngxExportInitHook') which runs soon after the
-- start of an Nginx worker process. Registered managers can then be referred to
-- from subrequest configurations by the key in field /manager/ (in JSON-encoded
-- configurations) or as /srManager = Custom \"key\"/ (in /read/-encoded
-- configurations).
--
-- Below is an example of a JSON-encoded subrequest configuration.
--
-- > {"uri": "http://example.com/", "manager": "mymanager"}
--
-- Note that keys /default/ and /uds/ have special meaning in field /manager/:
-- they denote internal HTTP and UDS managers respectively.
registerCustomManager
    :: ByteString       -- ^ Key
    -> Manager          -- ^ Manager
    -> IO ()
registerCustomManager :: ByteString -> Manager -> IO ()
registerCustomManager = (IORef (HashMap ByteString Manager)
-> (HashMap ByteString Manager -> HashMap ByteString Manager)
-> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef (HashMap ByteString Manager)
httpCustomManager ((HashMap ByteString Manager -> HashMap ByteString Manager)
 -> IO ())
-> (Manager
    -> HashMap ByteString Manager -> HashMap ByteString Manager)
-> Manager
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) ((Manager
  -> HashMap ByteString Manager -> HashMap ByteString Manager)
 -> Manager -> IO ())
-> (ByteString
    -> Manager
    -> HashMap ByteString Manager
    -> HashMap ByteString Manager)
-> ByteString
-> Manager
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString
-> Manager
-> HashMap ByteString Manager
-> HashMap ByteString Manager
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert

-- $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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$
              forall a. Binary a => a -> ByteString
Binary.encode @FullResponse
                  (Int
400, [], ByteString
"", ByteString
"Unreadable subrequest data")
          ) SubrequestConf -> IO ByteString
subrequestFull (Maybe SubrequestConf -> IO ByteString)
-> (ByteString -> Maybe SubrequestConf)
-> ByteString
-> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. FromJSON a => ByteString -> Maybe a
readFromByteStringAsJSON @SubrequestConf

ngxExportAsyncIOYY 'makeSubrequestFull

-- | 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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$
              forall a. Binary a => a -> ByteString
Binary.encode @FullResponse
                  (Int
400, [], ByteString
"", ByteString
"Unreadable subrequest data")
          ) SubrequestConf -> IO ByteString
subrequestFull (Maybe SubrequestConf -> IO ByteString)
-> (ByteString -> Maybe SubrequestConf)
-> ByteString
-> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Read a => ByteString -> Maybe a
readFromByteString @SubrequestConf

ngxExportAsyncIOYY 'makeSubrequestFullWithRead

-- | 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
.
    (\(Int
a, [(ByteString, ByteString)]
_, ByteString
_, ByteString
_) -> Int
a) (FullResponse -> Int)
-> (ByteString -> FullResponse) -> ByteString -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Binary a => ByteString -> a
Binary.decode @FullResponse (ByteString -> FullResponse)
-> (ByteString -> ByteString) -> ByteString -> FullResponse
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
L.fromStrict

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 ByteString
v =
    let (HeaderName
h, ByteString
b) = ByteString -> HeaderName
forall s. FoldCase s => s -> CI s
mk (ByteString -> HeaderName)
-> (ByteString -> ByteString)
-> (ByteString, ByteString)
-> (HeaderName, ByteString)
forall b c b' c'. (b -> c) -> (b' -> c') -> (b, b') -> (c, c')
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** HasCallStack => ByteString -> ByteString
ByteString -> ByteString
C8.tail ((ByteString, ByteString) -> (HeaderName, ByteString))
-> (ByteString, ByteString) -> (HeaderName, ByteString)
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> ByteString -> (ByteString, ByteString)
C8.break (Char
'|' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==) ByteString
v
        (Int
_, [(ByteString, ByteString)]
hs, ByteString
_, ByteString
_) = forall a. Binary a => ByteString -> a
Binary.decode @FullResponse (ByteString -> FullResponse) -> ByteString -> FullResponse
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
L.fromStrict ByteString
b
    in ByteString
-> (ByteString -> ByteString) -> Maybe ByteString -> ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString
"" ByteString -> ByteString
L.fromStrict (Maybe ByteString -> ByteString) -> Maybe ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ HeaderName -> RequestHeaders -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
h (RequestHeaders -> Maybe ByteString)
-> RequestHeaders -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ ((ByteString, ByteString) -> (HeaderName, ByteString))
-> [(ByteString, ByteString)] -> RequestHeaders
forall a b. (a -> b) -> [a] -> [b]
map ((ByteString -> HeaderName)
-> (ByteString, ByteString) -> (HeaderName, ByteString)
forall b c d. (b -> c) -> (b, d) -> (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ByteString -> HeaderName
forall s. FoldCase s => s -> CI s
mk) [(ByteString, ByteString)]
hs

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 =
    (\(Int
_, [(ByteString, ByteString)]
_, ByteString
a, ByteString
_) -> ByteString
a) (FullResponse -> ByteString)
-> (ByteString -> FullResponse) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Binary a => ByteString -> a
Binary.decode @FullResponse (ByteString -> FullResponse)
-> (ByteString -> ByteString) -> ByteString -> FullResponse
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
L.fromStrict

ngxExportYY 'extractBodyFromFullResponse

-- | 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
.
    (\(Int
_, [(ByteString, ByteString)]
_, ByteString
_, ByteString
a) -> ByteString
a) (FullResponse -> ByteString)
-> (ByteString -> FullResponse) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Binary a => ByteString -> a
Binary.decode @FullResponse (ByteString -> FullResponse)
-> (ByteString -> ByteString) -> ByteString -> FullResponse
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
L.fromStrict

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 HeaderName
notForwardableResponseHeaders = [HeaderName] -> HashSet HeaderName
forall a. (Eq a, Hashable a) => [a] -> HashSet a
HS.fromList ([HeaderName] -> HashSet HeaderName)
-> [HeaderName] -> HashSet HeaderName
forall a b. (a -> b) -> a -> b
$
    (ByteString -> HeaderName) -> [ByteString] -> [HeaderName]
forall a b. (a -> b) -> [a] -> [b]
map ByteString -> HeaderName
forall s. FoldCase s => s -> CI s
mk [ByteString
"Connection"
           ,ByteString
"Content-Length"
           ,ByteString
"Content-Type"
           ,ByteString
"Date"
           ,ByteString
"Keep-Alive"
           ,ByteString
"Last-Modified"
           ,ByteString
"Server"
           ,ByteString
"Transfer-Encoding"
           ,ByteString
"X-Pad"
           ]

deleteHeaders :: HashSet HeaderName -> Bool -> ResponseHeaders ->
    ResponseHeaders
deleteHeaders :: HashSet HeaderName -> Bool -> RequestHeaders -> RequestHeaders
deleteHeaders HashSet HeaderName
headersToDelete Bool
deleteXAccel =
    ((HeaderName, ByteString) -> Bool)
-> RequestHeaders -> RequestHeaders
forall a. (a -> Bool) -> [a] -> [a]
filter (\(HeaderName
n, ByteString
_) -> Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$
               HeaderName
n HeaderName -> HashSet HeaderName -> Bool
forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
`HS.member` HashSet HeaderName
headersToDelete Bool -> Bool -> Bool
||
                   Bool
deleteXAccel Bool -> Bool -> Bool
&&
                       ByteString -> ByteString
forall s. FoldCase s => s -> s
foldCase ByteString
"X-Accel-" ByteString -> ByteString -> Bool
`B.isPrefixOf` HeaderName -> ByteString
forall s. CI s -> s
foldedCase HeaderName
n
           )

-- | 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 HeaderName
-> Bool
-> (ByteString -> ByteString -> ByteString)
-> ByteString
-> ContentHandlerResult
contentFromFullResponse HashSet HeaderName
headersToDelete Bool
deleteXAccel ByteString -> ByteString -> ByteString
f ByteString
v =
    let (Int
st, [(ByteString, ByteString)]
hs, ByteString
b, ByteString
e) = forall a. Binary a => ByteString -> a
Binary.decode @FullResponse (ByteString -> FullResponse) -> ByteString -> FullResponse
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
L.fromStrict ByteString
v
        hs' :: RequestHeaders
hs' = ((ByteString, ByteString) -> (HeaderName, ByteString))
-> [(ByteString, ByteString)] -> RequestHeaders
forall a b. (a -> b) -> [a] -> [b]
map ((ByteString -> HeaderName)
-> (ByteString, ByteString) -> (HeaderName, ByteString)
forall b c d. (b -> c) -> (b, d) -> (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ByteString -> HeaderName
forall s. FoldCase s => s -> CI s
mk) [(ByteString, ByteString)]
hs
        ct :: ByteString
ct = ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
"" (Maybe ByteString -> ByteString) -> Maybe ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ HeaderName -> RequestHeaders -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (ByteString -> HeaderName
forall s. FoldCase s => s -> CI s
mk ByteString
"Content-Type") RequestHeaders
hs'
        hs'' :: RequestHeaders
hs'' = HashSet HeaderName -> Bool -> RequestHeaders -> RequestHeaders
deleteHeaders HashSet HeaderName
headersToDelete Bool
deleteXAccel RequestHeaders
hs'
    in (ByteString -> ByteString -> ByteString
f ByteString
b ByteString
e, ByteString
ct, Int
st, ((HeaderName, ByteString) -> (ByteString, ByteString))
-> RequestHeaders -> [(ByteString, ByteString)]
forall a b. (a -> b) -> [a] -> [b]
map ((HeaderName -> ByteString)
-> (HeaderName, ByteString) -> (ByteString, ByteString)
forall b c d. (b -> c) -> (b, d) -> (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first HeaderName -> ByteString
forall s. CI s -> s
original) RequestHeaders
hs'')

fromFullResponse :: ByteString -> ContentHandlerResult
fromFullResponse :: ByteString -> ContentHandlerResult
fromFullResponse =
    HashSet HeaderName
-> Bool
-> (ByteString -> ByteString -> ByteString)
-> ByteString
-> ContentHandlerResult
contentFromFullResponse HashSet HeaderName
notForwardableResponseHeaders Bool
True ByteString -> ByteString -> ByteString
forall a b. a -> b -> a
const

ngxExportHandler 'fromFullResponse

fromFullResponseWithException :: ByteString -> ContentHandlerResult
fromFullResponseWithException :: ByteString -> ContentHandlerResult
fromFullResponseWithException =
    HashSet HeaderName
-> Bool
-> (ByteString -> ByteString -> ByteString)
-> ByteString
-> ContentHandlerResult
contentFromFullResponse HashSet HeaderName
notForwardableResponseHeaders Bool
True ByteString -> ByteString -> ByteString
f
    where f :: ByteString -> ByteString -> ByteString
f ByteString
"" = ByteString -> ByteString
L.fromStrict
          f ByteString
b = ByteString -> ByteString -> ByteString
forall a b. a -> b -> a
const ByteString
b

ngxExportHandler 'fromFullResponseWithException

-- $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\"
--                         ,\"manager\": \"uds\"
--                         }
--                      }\';
--
--             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 SubrequestConf
conf Request
req =
    SubrequestConf -> Request -> Request
makeRequest SubrequestConf
conf { srMethod = "POST" , srBody = "" }
                Request
req { requestBody = RequestBodyStreamChunked givesPopper }

bridgedSubrequest :: (String -> IO Request) ->
    (Response L.ByteString -> L.ByteString) -> BridgeConf ->
    IO L.ByteString
bridgedSubrequest :: (String -> IO Request)
-> (Response ByteString -> ByteString)
-> BridgeConf
-> IO ByteString
bridgedSubrequest String -> IO Request
parseRequestF Response ByteString -> ByteString
buildResponseF BridgeConf {SubrequestConf
bridgeSource :: BridgeConf -> SubrequestConf
bridgeSink :: BridgeConf -> SubrequestConf
bridgeSource :: SubrequestConf
bridgeSink :: SubrequestConf
..} = do
    Manager
manIn <- SubrequestConf -> IO Manager
getManager SubrequestConf
bridgeSource
    Manager
manOut <- SubrequestConf -> IO Manager
getManager SubrequestConf
bridgeSink
    -- 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
$ \Response (IO ByteString)
respIn -> do
        let reqOut' :: Request
reqOut' = Request
reqOut { requestHeaders =
                                   deleteHeaders
                                       notForwardableResponseHeaders
                                       True (responseHeaders respIn)
                             }
            tmo :: Int
tmo = Request -> Manager -> Int
fromResponseTimeout Request
reqIn Manager
manIn
            givesPopper :: (IO ByteString -> b) -> b
givesPopper IO ByteString -> b
needsPopper = IO ByteString -> b
needsPopper (IO ByteString -> b) -> IO ByteString -> b
forall a b. (a -> b) -> a -> b
$
                Int -> Request -> IO ByteString -> IO ByteString
brReadWithTimeout Int
tmo Request
reqIn (IO ByteString -> IO ByteString) -> IO ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ Response (IO ByteString) -> IO ByteString
forall body. Response body -> body
responseBody Response (IO ByteString)
respIn
        Response ByteString -> ByteString
buildResponseF (Response ByteString -> ByteString)
-> IO (Response ByteString) -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
            Request -> Manager -> IO (Response ByteString)
httpLbsBrReadWithTimeout
                (GivesPopper () -> SubrequestConf -> Request -> Request
makeStreamingRequest GivesPopper ()
forall {b}. (IO ByteString -> b) -> b
givesPopper SubrequestConf
bridgeSink Request
reqOut') Manager
manOut

bridgedSubrequestBody :: BridgeConf -> IO L.ByteString
bridgedSubrequestBody :: BridgeConf -> IO ByteString
bridgedSubrequestBody = (String -> IO Request)
-> (Response ByteString -> ByteString)
-> BridgeConf
-> IO ByteString
bridgedSubrequest String -> IO Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseUrlThrow Response ByteString -> ByteString
forall body. Response body -> body
responseBody

bridgedSubrequestFull :: BridgeConf -> IO L.ByteString
bridgedSubrequestFull :: BridgeConf -> IO ByteString
bridgedSubrequestFull =
    IO ByteString -> IO ByteString
handleFullResponse (IO ByteString -> IO ByteString)
-> (BridgeConf -> IO ByteString) -> BridgeConf -> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> IO Request)
-> (Response ByteString -> ByteString)
-> BridgeConf
-> IO ByteString
bridgedSubrequest String -> IO Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseRequest Response ByteString -> ByteString
buildFullResponse

-- | 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. The
-- connection between the bridge ends is implemented via 'GivesPopper' and
-- 'RequestBodyStreamChunked' which means that the server bound at the sink end
-- must be capable of processing chunked requests.
--
-- 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/"
-- >      ,"manager": "uds"
-- >      }
-- > }
--
-- The sink method is always /POST/ while its body is always empty independently
-- of whether or not and how exactly they were specified. The sink response
-- timeout should be big enough to fulfill streaming of the response from the
-- source to the sink.
--
-- 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
.
        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)
-- >       , srManager = Default
-- >       }
-- > , bridgeSink = SubrequestConf
-- >       { srMethod = ""
-- >       , srUri = "http://127.0.0.1/sink"
-- >       , srBody = ""
-- >       , srHeaders = []
-- >       , srResponseTimeout = ResponseTimeout (Sec 30)
-- >       , srManager = Default
-- >       }
-- > }
--
-- The sink method is always /POST/ while its body is always empty independently
-- of how exactly they were specified. The sink response timeout should be big
-- enough to fulfill streaming of the response from the source to the sink.
--
-- 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
.
        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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$
              forall a. Binary a => a -> ByteString
Binary.encode @FullResponse
                  (Int
400, [], ByteString
"", ByteString
"Unreadable bridged subrequest data")
          ) BridgeConf -> IO ByteString
bridgedSubrequestFull (Maybe BridgeConf -> IO ByteString)
-> (ByteString -> Maybe BridgeConf) -> ByteString -> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. FromJSON a => ByteString -> Maybe a
readFromByteStringAsJSON @BridgeConf

ngxExportAsyncIOYY 'makeBridgedSubrequestFull

-- | 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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$
              forall a. Binary a => a -> ByteString
Binary.encode @FullResponse
                  (Int
400, [], ByteString
"", ByteString
"Unreadable bridged subrequest data")
          ) BridgeConf -> IO ByteString
bridgedSubrequestFull (Maybe BridgeConf -> IO ByteString)
-> (ByteString -> Maybe BridgeConf) -> ByteString -> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Read a => ByteString -> Maybe a
readFromByteString @BridgeConf

ngxExportAsyncIOYY 'makeBridgedSubrequestFullWithRead