ngx-export-tools-extra 0.3.2.1 → 0.4.0.0

raw patch · 4 files changed

+296/−23 lines, 4 filesdep +binarydep ~http-clientdep ~ngx-export-toolsPVP ok

version bump matches the API change (PVP)

Dependencies added: binary

Dependency ranges changed: http-client, ngx-export-tools

API changes (from Hackage documentation)

Files

• Changelog.md +5/−0
• NgxExport/Tools/EDE.hs +0/−1
• NgxExport/Tools/Subrequest.hs +287/−19
• ngx-export-tools-extra.cabal +4/−3

@@ -1,3 +1,8 @@+### 0.4.0.0++- Implemented adjustable response timeouts.+- Implemented subrequest handlers with ability to extract full response data.+ ### 0.3.2.0  - Functions and handlers *subrequest* and *subrequestWithRead* were renamed to

@@ -71,7 +71,6 @@ -- import           NgxExport -- import           NgxExport.Tools.EDE ----- import           Data.Char -- import           Data.ByteString (ByteString) -- import qualified Data.ByteString.Char8 as C8 -- import qualified Data.ByteString.Lazy as L

@@ -1,5 +1,5 @@ {-# LANGUAGE TemplateHaskell, OverloadedStrings, RecordWildCards #-}-{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeApplications, NumDecimals #-}  ----------------------------------------------------------------------------- -- |@@ -22,19 +22,31 @@     -- $makingHTTPSubrequests                                    makeSubrequest                                   ,makeSubrequestWithRead+    -- * Getting full response data from HTTP subrequests+    -- $gettingFullResponse+                                  ,makeSubrequestFull+                                  ,makeSubrequestFullWithRead+                                  ,extractStatusFromFullResponse+                                  ,extractHeaderFromFullResponse+                                  ,extractBodyFromFullResponse                                   ) where  import           NgxExport import           NgxExport.Tools -import           Network.HTTP.Client+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           Data.CaseInsensitive (mk)+import qualified Data.Binary as Binary+import           Data.CaseInsensitive (mk, original) import           Data.Aeson+import           Data.Maybe import           Control.Arrow import           Control.Exception import           System.IO.Unsafe@@ -183,11 +195,15 @@  instance Exception SubrequestParseError +data ResponseTimeout = ResponseTimeoutDefault+                     | ResponseTimeout TimeInterval deriving (Eq, Read)+ data SubrequestConf =-    SubrequestConf { srMethod  :: ByteString-                   , srUri     :: String-                   , srBody    :: ByteString-                   , srHeaders :: RequestHeaders+    SubrequestConf { srMethod          :: ByteString+                   , srUri             :: String+                   , srBody            :: ByteString+                   , srHeaders         :: RequestHeaders+                   , srResponseTimeout :: ResponseTimeout                    } deriving Read  instance FromJSON SubrequestConf where@@ -197,11 +213,14 @@         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 :: SubrequestConf -> IO L.ByteString-subrequest SubrequestConf {..} = do+subrequest :: (Response L.ByteString -> L.ByteString) -> SubrequestConf ->+    IO L.ByteString+subrequest fromResponse SubrequestConf {..} = do     req <- parseUrlThrow srUri     let req' = if B.null srMethod                    then req@@ -212,8 +231,43 @@         req''' = if null srHeaders                      then req''                      else req'' { requestHeaders = srHeaders }-    responseBody <$> httpLbs req''' httpManager+        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++type FullResponse = (Int, [(ByteString, L.ByteString)], L.ByteString)++subrequestFull :: SubrequestConf -> IO L.ByteString+subrequestFull = handleAll . subrequest buildResponse+    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 #-}@@ -226,13 +280,16 @@ -- service handler. -- -- Accepts a JSON object representing an opaque type /SubrequestConf/.--- The object may contain 4 fields: /method/ (optional, default is /GET/),--- /uri/ (mandatory), /body/ (optional, default is an empty value), and--- /headers/ (optional, default is an empty array).+-- 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/"}+-- > {"uri": "http://example.com/", "timeout": {"tag": "Sec", "contents": 10}} -- -- > {"uri": "http://127.0.0.1/subreq", "method": "POST", "body": "some value"} --@@ -246,8 +303,9 @@ makeSubrequest     :: ByteString       -- ^ Subrequest configuration     -> IO L.ByteString-makeSubrequest = maybe (throwIO SubrequestParseError) subrequest .-    readFromByteStringAsJSON @SubrequestConf+makeSubrequest =+    maybe (throwIO SubrequestParseError) subrequestBody .+        readFromByteStringAsJSON @SubrequestConf  ngxExportAsyncIOYY 'makeSubrequest @@ -260,9 +318,10 @@ -- An example of a subrequest configuration: -- -- > SubrequestConf { srMethod = ""--- >                , srUri = "http://127.0.0.1/subreq"}+-- >                , 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@@ -271,8 +330,217 @@ makeSubrequestWithRead     :: ByteString       -- ^ Subrequest configuration     -> IO L.ByteString-makeSubrequestWithRead = maybe (throwIO SubrequestParseError) subrequest .-    readFromByteString @SubrequestConf+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'.+--+-- Exported on the Nginx level by a handler of the same name.+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'.+--+-- Exported on the Nginx level by a handler of the same name.+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' and+-- 'makeSubrequestFullWithRead'.+--+-- Exported on the Nginx level by a handler of the same name.+extractStatusFromFullResponse :: ByteString -> 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' and+-- 'makeSubrequestFullWithRead'.+--+-- 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.+--+-- Exported on the Nginx level by a handler of the same name.+extractHeaderFromFullResponse :: ByteString -> 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' and+-- 'makeSubrequestFullWithRead'.+--+-- Exported on the Nginx level by a handler of the same name.+extractBodyFromFullResponse :: ByteString -> L.ByteString+extractBodyFromFullResponse =+    (\(_, _, a) -> a) . (Binary.decode @FullResponse) . L.fromStrict++ngxExportYY 'extractBodyFromFullResponse 

@@ -1,5 +1,5 @@ name:                       ngx-export-tools-extra-version:                    0.3.2.1+version:                    0.4.0.0 synopsis:                   More extra tools for Nginx haskell module description:                More extra tools for         <https://github.com/lyokha/nginx-haskell-module Nginx haskell module>.@@ -34,10 +34,11 @@                           , bytestring >= 0.10.0.0                           , base64 >= 0.3.0.0                           , ngx-export-                          , ngx-export-tools >= 0.4.5.0+                          , ngx-export-tools >= 0.4.8.0                           , aeson >= 1.0.0.0                           , http-types >= 0.7.0-                          , http-client+                          , http-client >= 0.5.0+                          , binary                           , case-insensitive                           , containers                           , unordered-containers