Options: hold a [MediaType] to be considered for binary responses

A careful reading between the lines of the [API Gateway documentation][1]
implies that if `binaryMediaTypes` is not set on the API Gateway, all
responses are considered to be text. So we should be able to get away
with an explicit list of media types that require binary responses,
and we can ask the developer to ensure that it matches the
`binaryMediaTypes` setting on his or her API.

[1]: https://docs.aws.amazon.com/apigateway/latest/developerguide/api-gateway-payload-encodings-workflow.html

CHANGELOG.md

@@ -6,6 +6,19 @@
   Application -> ProxyRequest NoAuthorizer -> ProxyResponse`. This
   provides a convenient way to pass custom `Options` without all the
   bells and whistles of `runWithContext`.
+
+- Instead of guessing whether a given response `Content-Type` should
+  be sent as text or base64-encoded binary, `Options` now contains a
+  `binaryMediaTypes :: [MediaType]`, which lists the media types that
+  should be base64-encoded. This should match the `binaryMediaTypes`
+  setting you have configured on the API Gateway that integrates with
+  your Lambda Function.
+
+  _See:_ [Content type conversion in API
+    Gateway](https://docs.aws.amazon.com/apigateway/latest/developerguide/api-gateway-payload-encodings-workflow.html)
+    in the [Amazon API Gateway Developer
+    Guide](https://docs.aws.amazon.com/apigateway/latest/developerguide/).
+
 ## 0.3.0.0 -- 2023-12-17
 
 - Accidental breaking change: more elaborate `Content-Type` headers

src/Network/Wai/Handler/Hal.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE TupleSections #-}
@@ -62,11 +63,13 @@ import Data.HashMap.Lazy (HashMap)
 import qualified Data.HashMap.Lazy as H
 import qualified Data.IORef as IORef
 import Data.List (foldl', sort)
+import Data.Maybe (fromMaybe)
 import Data.Text (Text)
 import qualified Data.Text as T
 import qualified Data.Text.Encoding as T
 import Data.Vault.Lazy (Key, Vault)
 import qualified Data.Vault.Lazy as Vault
+import Network.HTTP.Media (MediaType, matches, parseAccept, renderHeader)
 import Network.HTTP.Types.Header
   ( HeaderName,
     ResponseHeaders,
@@ -119,17 +122,20 @@ data Options = Options
     -- have to tell it yourself. This is almost always going to be 443
     -- (HTTPS).
     portNumber :: PortNumber,
-    -- | Binary responses need to be encoded as base64. This option lets you
-    -- customize which mime types are considered binary data.
+    -- | To return binary data, API Gateway requires you to configure
+    -- the @binaryMediaTypes@ setting on your API, and then
+    -- base64-encode your binary responses.
     --
-    -- The following mime types are __not__ considered binary by default:
+    -- If the @Content-Type@ header in the @wai@ 'Wai.Response'
+    -- matches any of the media types in this field, @wai-handler-hal@
+    -- will base64-encode its response to the API Gateway.
     --
-    -- * @application/json@
-    -- * @application/xml@
-    -- * anything starting with @text/@
-    -- * anything ending with @+json@
-    -- * anything ending with @+xml@
-    binaryMimeType :: Text -> Bool
+    -- If you set @binaryMediaTypes@ in your API, you should override
+    -- the default (empty) list to match.
+    --
+    -- /See:/ [Content type conversion in API Gateway](https://docs.aws.amazon.com/apigateway/latest/developerguide/api-gateway-payload-encodings-workflow.html)
+    -- in the [Amazon API Gateway Developer Guide](https://docs.aws.amazon.com/apigateway/latest/developerguide/).
+    binaryMediaTypes :: [MediaType]
   }
 
 -- | Default options for running 'Wai.Application's on Lambda.
@@ -138,13 +144,7 @@ defaultOptions =
   Options
     { vault = Vault.empty,
       portNumber = 443,
-      binaryMimeType = \mime -> case mime of
-        "application/json" -> False
-        "application/xml" -> False
-        _ | "text/" `T.isPrefixOf` mime -> False
-        _ | "+json" `T.isSuffixOf` mime -> False
-        _ | "+xml" `T.isSuffixOf` mime -> False
-        _ -> True
+      binaryMediaTypes = []
     }
 
 -- | A variant of 'run' with configurable 'Options'. Useful if you
@@ -346,12 +346,18 @@ readFilePart path mPart = withFile path ReadMode $ \h -> do
       hSeek h AbsoluteSeek offset
       B.hGet h $ fromIntegral count
 
-createProxyBody :: Options -> Text -> ByteString -> HalResponse.ProxyBody
-createProxyBody opts contentType body
-  | binaryMimeType opts contentType =
-      HalResponse.ProxyBody contentType (T.decodeUtf8 $ B64.encode body) True
-  | otherwise =
-      HalResponse.ProxyBody contentType (T.decodeUtf8 body) False
+createProxyBody :: Options -> MediaType -> ByteString -> HalResponse.ProxyBody
+createProxyBody opts contentType body =
+  HalResponse.ProxyBody
+    { HalResponse.contentType = T.decodeUtf8 $ renderHeader contentType,
+      HalResponse.serialized =
+        if isBase64Encoded
+          then T.decodeUtf8 $ B64.encode body
+          else T.decodeUtf8 body,
+      HalResponse.isBase64Encoded
+    }
+  where
+    isBase64Encoded = any (contentType `matches`) $ binaryMediaTypes opts
 
 addHeaders ::
   ResponseHeaders -> HalResponse.ProxyResponse -> HalResponse.ProxyResponse
@@ -365,6 +371,7 @@ addHeaders headers response = foldl' addHeader response headers
 
 -- | Try to find the content-type of a response, given the response
 -- headers. If we can't, return @"application/octet-stream"@.
-getContentType :: ResponseHeaders -> Text
-getContentType =
-  maybe "application/octet-stream" T.decodeUtf8 . lookup hContentType
+getContentType :: ResponseHeaders -> MediaType
+getContentType headers =
+  fromMaybe "application/octet-stream" $
+    lookup hContentType headers >>= parseAccept

test/Network/Wai/Handler/HalTest.hs

@@ -1,17 +1,26 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
 module Network.Wai.Handler.HalTest where
 
-import AWS.Lambda.Events.ApiGateway.ProxyRequest
+import AWS.Lambda.Events.ApiGateway.ProxyRequest (ProxyRequest)
+import AWS.Lambda.Events.ApiGateway.ProxyResponse
+  ( ProxyBody (..),
+    ProxyResponse (..),
+  )
 import Data.Aeson (eitherDecodeFileStrict')
-import qualified Data.Text as T
+import qualified Data.ByteString.Base64 as B64
+import qualified Data.Text.Encoding as T
 import qualified Data.Text.Lazy.Encoding as TL
 import Data.Void (Void)
+import Network.HTTP.Types (hContentType, ok200)
+import Network.Wai (Response, responseLBS)
 import Network.Wai.Handler.Hal
-import Test.Tasty
-import Test.Tasty.Golden
+import Test.Tasty (TestTree)
+import Test.Tasty.Golden (goldenVsString)
 import Test.Tasty.HUnit (assertEqual, testCase)
-import Text.Pretty.Simple
+import Text.Pretty.Simple (pShowNoColor)
 
 test_ConvertProxyRequest :: TestTree
 test_ConvertProxyRequest =
@@ -22,22 +31,25 @@ test_ConvertProxyRequest =
     waiRequest <- toWaiRequest defaultOptions proxyRequest
     pure . TL.encodeUtf8 $ pShowNoColor waiRequest
 
-test_DefaultBinaryMimeTypes :: TestTree
-test_DefaultBinaryMimeTypes = testCase "default binary MIME types" $ do
-  assertBinary False "text/plain"
-  assertBinary False "text/html"
-  assertBinary False "application/json"
-  assertBinary False "application/xml"
-  assertBinary False "application/vnd.api+json"
-  assertBinary False "application/vnd.api+xml"
-  assertBinary False "image/svg+xml"
-
-  assertBinary True "application/octet-stream"
-  assertBinary True "audio/vorbis"
-  assertBinary True "image/png"
-  where
-    assertBinary expected mime =
-      assertEqual
-        mime
-        (binaryMimeType defaultOptions (T.pack mime))
-        expected
+test_BinaryResponse :: TestTree
+test_BinaryResponse = testCase "Responding to API Gateway with text" $ do
+  let options = defaultOptions {binaryMediaTypes = ["*/*"]}
+  ProxyResponse {body = ProxyBody {..}} <-
+    fromWaiResponse options helloWorld
+
+  assertEqual "response is binary" True isBase64Encoded
+  assertEqual
+    "response is base64-encoded"
+    (Right "Hello, World!")
+    (B64.decode (T.encodeUtf8 serialized))
+
+test_TextResponse :: TestTree
+test_TextResponse = testCase "Responding to API Gateway with text" $ do
+  ProxyResponse {body = ProxyBody {..}} <-
+    fromWaiResponse defaultOptions helloWorld
+
+  assertEqual "response is not binary" False isBase64Encoded
+  assertEqual "response is unmangled" "Hello, World!" serialized
+
+helloWorld :: Response
+helloWorld = responseLBS ok200 [(hContentType, "text/plain")] "Hello, World!"

wai-handler-hal.cabal

@@ -52,6 +52,7 @@ common deps
     , bytestring            >=0.10.8    && <0.12.1
     , case-insensitive      ^>=1.2.0.0
     , hal                   >=0.4.7     && <0.4.11 || >=1.0.0 && <1.2
+    , http-media            ^>=0.8.1.1
     , http-types            ^>=0.12.3
     , network               >=2.8.0.0   && <3.2
     , text                  ^>=1.2.3    || >=2.0   && <2.1.1