{-# 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
-- * Getting full response data from HTTP subrequests
-- $gettingFullResponse
,makeSubrequestFull
,makeSubrequestFullWithRead
,extractStatusFromFullResponse
,extractHeaderFromFullResponse
,extractBodyFromFullResponse
-- * 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 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 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 (FoldCase (foldCase), mk, original)
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 Show
instance Exception SubrequestParseError
data ResponseTimeout = ResponseTimeoutDefault
| ResponseTimeout TimeInterval deriving (Eq, Read)
data SubrequestConf =
SubrequestConf { srMethod :: ByteString
, srUri :: String
, srBody :: ByteString
, srHeaders :: RequestHeaders
, srResponseTimeout :: ResponseTimeout
} deriving Read
instance FromJSON SubrequestConf where
parseJSON = withObject "SubrequestConf" $ \o -> do
srMethod <- maybeEmpty $ o .:? "method"
srUri <- o .: "uri"
srBody <- maybeEmpty $ o .:? "body"
srHeaders <- map (mk . T.encodeUtf8 *** T.encodeUtf8) <$>
o .:? "headers" .!= []
srResponseTimeout <- maybe ResponseTimeoutDefault ResponseTimeout <$>
o .:? "timeout"
return SubrequestConf {..}
where maybeEmpty = fmap $ maybe "" T.encodeUtf8
subrequest :: (Response L.ByteString -> L.ByteString) ->
(String -> IO Request) -> SubrequestConf -> IO L.ByteString
subrequest fromResponse parseUrlF SubrequestConf {..} = do
req <- parseUrlF srUri
let req' = if B.null srMethod
then req
else req { method = srMethod }
req'' = if B.null srBody
then req'
else req' { requestBody = RequestBodyBS srBody }
req''' = if null srHeaders
then req''
else req'' { requestHeaders = srHeaders }
req'''' = if srResponseTimeout == ResponseTimeoutDefault
then req'''
else req''' { responseTimeout =
setTimeout srResponseTimeout }
fromResponse <$> httpLbs req'''' httpManager
where setTimeout (ResponseTimeout v)
| t == 0 = responseTimeoutNone
| otherwise = responseTimeoutMicro $ t * 1e6
where t = toSec v
setTimeout _ = undefined
subrequestBody :: SubrequestConf -> IO L.ByteString
subrequestBody = subrequest responseBody parseUrlThrow
type FullResponse = (Int, [(ByteString, L.ByteString)], L.ByteString)
subrequestFull :: SubrequestConf -> IO L.ByteString
subrequestFull = handleAll . subrequest buildResponse parseRequest
where handleAll = handle $ \e -> return $ Binary.encode @FullResponse $
case fromException e of
Just (HttpExceptionRequest _ c) ->
case c of
StatusCodeException r _ ->
(statusCode $ responseStatus r, [], "")
Network.HTTP.Client.ResponseTimeout -> response502
ConnectionTimeout -> response502
ConnectionFailure _ -> response502
_ -> response500
_ -> response500
response500 = (500, [], "")
response502 = (502, [], "")
buildResponse r =
let status = statusCode $ responseStatus r
headers = map (first original) $ responseHeaders r
body = responseBody r
in Binary.encode (status, headers, body)
httpManager :: Manager
httpManager = unsafePerformIO $ newManager defaultManagerSettings
{-# NOINLINE httpManager #-}
-- | 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 =
maybe (throwIO SubrequestParseError) subrequestBody .
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)
-- > }
--
-- 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 =
maybe (throwIO SubrequestParseError) subrequestBody .
readFromByteString @SubrequestConf
ngxExportAsyncIOYY 'makeSubrequestWithRead
-- $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.
--
-- 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', and
-- 'extractBodyFromFullResponse'. It also does not throw errors when HTTP status
-- of the response is not /2xx/. Exported on the Nginx level by handler
-- /makeSubrequestFull/.
makeSubrequestFull
:: ByteString -- ^ Subrequest configuration
-> IO L.ByteString
makeSubrequestFull =
maybe (return $ Binary.encode @FullResponse (400, [], "")) subrequestFull .
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', and
-- 'extractBodyFromFullResponse'. It also does not throw errors when HTTP status
-- of the response is not /2xx/. Exported on the Nginx level by handler
-- /makeSubrequestFullWithRead/.
makeSubrequestFullWithRead
:: ByteString -- ^ Subrequest configuration
-> IO L.ByteString
makeSubrequestFullWithRead =
maybe (return $ Binary.encode @FullResponse (400, [], "")) subrequestFull .
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 = C8L.pack . show .
(\(a, _, _) -> a) . (Binary.decode @FullResponse) . 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 v =
let (h, b) = mk *** C8.tail $ C8.break ('|' ==) v
hs = (\(_, a, _) -> map (first mk) a) $
Binary.decode @FullResponse $ L.fromStrict b
in fromMaybe L.empty $ lookup h 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 =
(\(_, _, a) -> a) . (Binary.decode @FullResponse) . L.fromStrict
ngxExportYY 'extractBodyFromFullResponse
-- $forwardingFullResponse
--
-- Data encoded in the full response can be translated to 'ContentHandlerResult'
-- and forwarded downstream to the client in directive /haskell_content/.
-- Handler __/fromFullResponse/__ performs 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 = HS.fromList $
map 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/. Handler /fromFullResponse/
-- forwards the response to the client after deleting headers listed in set
-- 'notForwardableResponseHeaders' and headers with names starting with
-- /X-Accel-/.
contentFromFullResponse
:: HashSet HeaderName -- ^ Set of not forwardable response headers
-> Bool -- ^ Do not forward /X-Accel-.../ response headers
-> ByteString -- ^ Encoded HTTP response
-> ContentHandlerResult
contentFromFullResponse headersToDelete deleteXAccel v =
let (st, hs, b) = Binary.decode @FullResponse $ L.fromStrict v
hs' = map (first mk) hs
ct = L.toStrict $ fromMaybe "" $ lookup (mk "Content-Type") hs'
hs'' = filter (\(n, _) -> not $
mk n `HS.member` headersToDelete ||
deleteXAccel &&
foldCase "X-Accel-" `B.isPrefixOf` foldCase n
) hs
in (b, ct, st, map (second L.toStrict) hs'')
fromFullResponse :: ByteString -> ContentHandlerResult
fromFullResponse = contentFromFullResponse notForwardableResponseHeaders True
ngxExportHandler 'fromFullResponse