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

-----------------------------------------------------------------------------
-- |
-- Module      :  NgxExport.Tools.Subrequest
-- Copyright   :  (c) Alexey Radkov 2020
-- 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
                                  ) where

import           NgxExport
import           NgxExport.Tools

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

-- $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;
--         }
--
--         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 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

subrequest :: (String -> IO Request) ->
    (Response L.ByteString -> L.ByteString) -> SubrequestConf ->
    IO L.ByteString
subrequest :: (String -> IO Request)
-> (Response ByteString -> ByteString)
-> SubrequestConf
-> IO ByteString
subrequest parseRequestF :: String -> IO Request
parseRequestF buildResponseF :: Response ByteString -> ByteString
buildResponseF SubrequestConf {..} = do
    Manager
man <- if Bool
srUseUDS
               then Manager -> Maybe Manager -> Manager
forall a. a -> Maybe a -> a
fromMaybe (UDSNotConfiguredError -> Manager
forall a e. Exception e => e -> a
throw UDSNotConfiguredError
UDSNotConfiguredError) (Maybe Manager -> Manager) -> IO (Maybe Manager) -> IO Manager
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                        IORef (Maybe Manager) -> IO (Maybe Manager)
forall a. IORef a -> IO a
readIORef IORef (Maybe Manager)
httpUDSManager
               else Manager -> IO Manager
forall (m :: * -> *) a. Monad m => a -> m a
return Manager
httpManager
    Request
req <- String -> IO Request
parseRequestF String
srUri
    let req' :: Request
req' = if ByteString -> Bool
B.null ByteString
srMethod
                   then Request
req
                   else Request
req { method :: ByteString
method = ByteString
srMethod }
        req'' :: Request
req'' = if ByteString -> Bool
B.null ByteString
srBody
                    then Request
req'
                    else Request
req' { requestBody :: RequestBody
requestBody = ByteString -> RequestBody
RequestBodyBS ByteString
srBody }
        req''' :: Request
req''' = if RequestHeaders -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null RequestHeaders
srHeaders
                     then Request
req''
                     else Request
req'' { requestHeaders :: RequestHeaders
requestHeaders = RequestHeaders
srHeaders }
        req'''' :: Request
req'''' = if ResponseTimeout
srResponseTimeout ResponseTimeout -> ResponseTimeout -> Bool
forall a. Eq a => a -> a -> Bool
== ResponseTimeout
ResponseTimeoutDefault
                      then Request
req'''
                      else Request
req''' { responseTimeout :: ResponseTimeout
responseTimeout =
                                        ResponseTimeout -> ResponseTimeout
setTimeout ResponseTimeout
srResponseTimeout }
    Response ByteString -> ByteString
buildResponseF (Response ByteString -> ByteString)
-> IO (Response ByteString) -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Request -> Manager -> IO (Response ByteString)
httpLbs Request
req'''' Manager
man
    where setTimeout :: ResponseTimeout -> ResponseTimeout
setTimeout (ResponseTimeout v :: TimeInterval
v)
              | Int
t Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0 = ResponseTimeout
responseTimeoutNone
              | Bool
otherwise = Int -> ResponseTimeout
responseTimeoutMicro (Int -> ResponseTimeout) -> Int -> ResponseTimeout
forall a b. (a -> b) -> a -> b
$ Int
t Int -> Int -> Int
forall a. Num a => a -> a -> a
* 1e6
              where t :: Int
t = TimeInterval -> Int
toSec TimeInterval
v
          setTimeout _ = ResponseTimeout
forall a. HasCallStack => a
undefined

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

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

subrequestFull :: SubrequestConf -> IO L.ByteString
subrequestFull :: SubrequestConf -> IO ByteString
subrequestFull = IO ByteString -> IO ByteString
handleAll (IO ByteString -> IO ByteString)
-> (SubrequestConf -> IO ByteString)
-> SubrequestConf
-> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> IO Request)
-> (Response ByteString -> ByteString)
-> SubrequestConf
-> IO ByteString
subrequest String -> IO Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseRequest Response ByteString -> ByteString
buildResponse
    where handleAll :: IO ByteString -> IO ByteString
handleAll = (SomeException -> IO ByteString) -> IO ByteString -> IO ByteString
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle ((SomeException -> IO ByteString)
 -> IO ByteString -> IO ByteString)
-> (SomeException -> IO ByteString)
-> IO ByteString
-> IO ByteString
forall a b. (a -> b) -> a -> b
$ \e :: SomeException
e -> do
              let msg :: ByteString
msg = String -> ByteString
C8.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ SomeException -> String
forall a. Show a => a -> String
show SomeException
e
                  response500 :: (Int, [a], ByteString, ByteString)
response500 = (500, [], "", ByteString
msg)
                  response502 :: (Int, [a], ByteString, ByteString)
response502 = (502, [], "", ByteString
msg)
              ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ Binary FullResponse => FullResponse -> ByteString
forall a. Binary a => a -> ByteString
Binary.encode @FullResponse (FullResponse -> ByteString) -> FullResponse -> ByteString
forall a b. (a -> b) -> a -> b
$
                  case SomeException -> Maybe HttpException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e of
                      Just (HttpExceptionRequest _ c :: HttpExceptionContent
c) ->
                          case HttpExceptionContent
c of
                              Network.HTTP.Client.ResponseTimeout -> FullResponse
forall a. (Int, [a], ByteString, ByteString)
response502
                              ConnectionTimeout -> FullResponse
forall a. (Int, [a], ByteString, ByteString)
response502
                              ConnectionFailure _ -> FullResponse
forall a. (Int, [a], ByteString, ByteString)
response502
                              _ -> FullResponse
forall a. (Int, [a], ByteString, ByteString)
response500
                      _ -> FullResponse
forall a. (Int, [a], ByteString, ByteString)
response500
          buildResponse :: Response ByteString -> ByteString
buildResponse r :: Response ByteString
r =
              let status :: Int
status = Status -> Int
statusCode (Status -> Int) -> Status -> Int
forall a b. (a -> b) -> a -> b
$ Response ByteString -> Status
forall body. Response body -> Status
responseStatus Response ByteString
r
                  headers :: [(ByteString, ByteString)]
headers = (Header -> (ByteString, ByteString))
-> RequestHeaders -> [(ByteString, ByteString)]
forall a b. (a -> b) -> [a] -> [b]
map ((CI ByteString -> ByteString) -> Header -> (ByteString, ByteString)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first CI ByteString -> ByteString
forall s. CI s -> s
original) (RequestHeaders -> [(ByteString, ByteString)])
-> RequestHeaders -> [(ByteString, ByteString)]
forall a b. (a -> b) -> a -> b
$ Response ByteString -> RequestHeaders
forall body. Response body -> RequestHeaders
responseHeaders Response ByteString
r
                  body :: ByteString
body = Response ByteString -> ByteString
forall body. Response body -> body
responseBody Response ByteString
r
              in FullResponse -> ByteString
forall a. Binary a => a -> ByteString
Binary.encode @FullResponse (Int
status, [(ByteString, ByteString)]
headers, ByteString
body, "")

httpManager :: Manager
httpManager :: Manager
httpManager = IO Manager -> Manager
forall a. IO a -> a
unsafePerformIO (IO Manager -> Manager) -> IO Manager -> Manager
forall a b. (a -> b) -> a -> b
$ ManagerSettings -> IO Manager
newManager ManagerSettings
defaultManagerSettings
{-# NOINLINE httpManager #-}

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

-- | 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 handler deletes 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/
-- @
--             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'

-- | 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"
           ]

-- | 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'' = (Header -> Bool) -> RequestHeaders -> RequestHeaders
forall a. (a -> Bool) -> [a] -> [a]
filter
            (\(n :: CI ByteString
n, _) -> Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$
                CI ByteString
n CI ByteString -> HashSet (CI ByteString) -> Bool
forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
`HS.member` HashSet (CI ByteString)
headersToDelete Bool -> Bool -> Bool
||
                    Bool
deleteXAccel Bool -> Bool -> Bool
&&
                        ByteString -> ByteString
forall s. FoldCase s => s -> s
foldCase "X-Accel-" ByteString -> ByteString -> Bool
`B.isPrefixOf` CI ByteString -> ByteString
forall s. CI s -> s
foldedCase CI ByteString
n
            ) RequestHeaders
hs'
    in (ByteString -> ByteString -> ByteString
f ByteString
b ByteString
e, ByteString
ct, Int
st, (Header -> (ByteString, ByteString))
-> RequestHeaders -> [(ByteString, ByteString)]
forall a b. (a -> b) -> [a] -> [b]
map ((CI ByteString -> ByteString) -> Header -> (ByteString, ByteString)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first CI ByteString -> ByteString
forall s. CI s -> s
original) RequestHeaders
hs'')

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

ngxExportHandler 'fromFullResponse

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

ngxExportHandler 'fromFullResponseWithException