{-# 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 -- . -- ----------------------------------------------------------------------------- module NgxExport.Tools.Subrequest ( -- * Making HTTP subrequests -- $makingHTTPSubrequests makeSubrequest ,makeSubrequestWithRead -- * Getting full response data from HTTP subrequests -- $gettingFullResponse ,makeSubrequestFull ,makeSubrequestFullWithRead ,extractRequestStatusFromFullResponse ,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 Data.Word 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 -- > -- > -- > -- > -- > -- > httpbin.org -- > rel="stylesheet"> -- > -- > -- -- > $ 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 :: (String -> IO Request) -> (Response L.ByteString -> L.ByteString) -> SubrequestConf -> IO L.ByteString subrequest parseRequestF buildResponseF SubrequestConf {..} = do req <- parseRequestF 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 } buildResponseF <$> 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 parseUrlThrow responseBody type FullResponse = (Word8, Int, [(ByteString, ByteString)], L.ByteString) subrequestFull :: SubrequestConf -> IO L.ByteString subrequestFull = handleAll . subrequest parseRequest buildResponse where handleAll = handle $ \e -> return $ Binary.encode @FullResponse $ case fromException e of Just (HttpExceptionRequest _ c) -> case c of StatusCodeException r _ -> (0, statusCode $ responseStatus r, [], "") Network.HTTP.Client.ResponseTimeout -> response502 ConnectionTimeout -> response502 ConnectionFailure _ -> response502 _ -> response500 _ -> response500 response500 = (2, 500, [], "") response502 = (1, 502, [], "") buildResponse r = let status = statusCode $ responseStatus r headers = map (first original) $ responseHeaders r body = responseBody r in Binary.encode @FullResponse (0, 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. Handler __/extractRequestStatusFromFullResponse/__ and the -- corresponding function can be used to extract the request status: /0/ means -- that the request was completed without technical errors, /1/ means that the -- request failed due to connection errors including timeouts, and /2/ means -- that the request failed due to other errors. -- -- 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 -- 'extractRequestStatusFromFullResponse', '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 (2, 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 -- 'extractRequestStatusFromFullResponse', '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 (2, 400, [], "")) subrequestFull . readFromByteString @SubrequestConf ngxExportAsyncIOYY 'makeSubrequestFullWithRead -- | Extracts the request status from an encoded response. -- -- Must be used to extract response data encoded by 'makeSubrequestFull' or -- 'makeSubrequestFullWithRead'. Exported on the Nginx level by handler -- /extractRequestStatusFromFullResponse/. -- -- The request status may be one of the following values: -- -- - /0/ — the request was completed without technical errors, -- - /1/ — the request failed due to connection errors including timeouts, -- - /2/ — the request failed due to other errors. extractRequestStatusFromFullResponse :: ByteString -- ^ Encoded HTTP response -> L.ByteString extractRequestStatusFromFullResponse = C8L.pack . show . (\(a, _, _, _) -> a) . (Binary.decode @FullResponse) . L.fromStrict ngxExportYY 'extractRequestStatusFromFullResponse -- | 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 maybe "" L.fromStrict $ 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 = 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, hs'') fromFullResponse :: ByteString -> ContentHandlerResult fromFullResponse = contentFromFullResponse notForwardableResponseHeaders True ngxExportHandler 'fromFullResponse