enhance request handling with NFData instances

gen/src/Gen/AST/Data/Syntax.hs

@@ -366,10 +366,14 @@ requestD c m h (a, as) (b, bs) =
     "Core.AWSRequest"
     (identifier a)
     $ Just
-      [ assocD (identifier a) "AWSResponse" (typeId (identifier b)),
-        funArgsD "request" ["overrides"] (requestF c m h a as),
-        funD "response" (responseE (m ^. protocol) b bs)
-      ]
+      ( [assocD (identifier a) "AWSResponse" (typeId (identifier b))]
+          ++ [ funArgsD "evaluateResponse" ["_"] (var "Prelude.rnf")
+             | not (any fieldStream (notLocated bs))
+             ]
+          ++ [ funArgsD "request" ["overrides"] (requestF c m h a as),
+               funD "response" (responseE (m ^. protocol) b bs)
+             ]
+      )
 
 responseE :: Protocol -> Ref -> [Field] -> Exp
 responseE p r fs = Exts.app (responseF p r fs) bdy

lib/amazonka-core/src/Amazonka/Types.hs

@@ -662,6 +662,18 @@ class (Typeable a, Typeable (AWSResponse a)) => AWSRequest a where
   -- | The successful, expected response associated with a request.
   type AWSResponse a :: Type
 
+  -- | Evaluate a successful response before returning it from a send operation
+  -- or passing it to a waiter acceptor.
+  --
+  -- The default evaluates only the outer constructor, which preserves
+  -- streaming responses. Generated non-streaming requests override this
+  -- with 'rnf'.
+  --
+  -- Evaluation happens after response hooks. Any exception raised by this
+  -- method is propagated through IO and is not converted to 'Error'.
+  evaluateResponse :: a -> AWSResponse a -> ()
+  evaluateResponse _ result = result `seq` ()
+
   request ::
     -- | Overrides applied to the default 'Service'.
     (Service -> Service) ->
@@ -952,7 +964,6 @@ pattern TelAviv = Region' "il-central-1"
 pattern MexicoCentral :: Region
 pattern MexicoCentral = Region' "mx-central-1"
 
-
 -- Middle East
 
 pattern Bahrain :: Region

lib/amazonka-s3-encryption/amazonka-s3-encryption.cabal

@@ -120,7 +120,9 @@ test-suite amazonka-s3-encryption-test
   -- This section is encoded by the template and any modules added by
   -- hand outside these namespaces will not correctly be added to the
   -- distribution package.
-  other-modules:    Test.Amazonka.S3.Encryption.Envelope
+  other-modules:
+    Test.Amazonka.S3.Encryption.Encrypt
+    Test.Amazonka.S3.Encryption.Envelope
   build-depends:
     , amazonka-core
     , amazonka-s3-encryption

lib/amazonka-s3-encryption/src/Amazonka/S3/Encryption/Encrypt.hs

@@ -61,6 +61,8 @@ envelope = _encEnvelope
 instance (AWSRequest a) => AWSRequest (Encrypted a) where
   type AWSResponse (Encrypted a) = AWSResponse a
 
+  evaluateResponse (Encrypted x _ _ _) = evaluateResponse x
+
   request overrides (Encrypted x xs l e) =
     coerce (request overrides x) & updateBodyAndHeaders
     where

lib/amazonka-s3-encryption/src/Amazonka/S3/Encryption/Instructions.hs

@@ -65,6 +65,8 @@ piExtension = Lens.lens _piExt (\s a -> s {_piExt = a})
 instance AWSRequest PutInstructions where
   type AWSResponse PutInstructions = S3.PutObjectResponse
 
+  evaluateResponse _ = rnf
+
   request overrides x =
     coerce . request overrides $
       _piPut x & S3.putObject_key %~ appendExtension (_piExt x)
@@ -130,6 +132,8 @@ diExtension = Lens.lens _diExt (\s a -> s {_diExt = a})
 instance AWSRequest DeleteInstructions where
   type AWSResponse DeleteInstructions = S3.DeleteObjectResponse
 
+  evaluateResponse _ = rnf
+
   request overrides x =
     coerce . request overrides $
       _diDelete x & S3.deleteObject_key %~ appendExtension (_diExt x)

lib/amazonka-s3-encryption/test/Main.hs

@@ -2,6 +2,7 @@
 
 module Main (main) where
 
+import Test.Amazonka.S3.Encryption.Encrypt
 import Test.Amazonka.S3.Encryption.Envelope
 import Test.Tasty
 
@@ -10,5 +11,6 @@ main =
   defaultMain $
     testGroup
       "S3-encryption"
-      [ testGroup "envelope" envelopeTests
+      [ testGroup "envelope" envelopeTests,
+        encryptTests
       ]

lib/amazonka-s3-encryption/test/Test/Amazonka/S3/Encryption/Encrypt.hs

@@ -0,0 +1,43 @@
+{-# LANGUAGE TypeFamilies #-}
+
+module Test.Amazonka.S3.Encryption.Encrypt (encryptTests) where
+
+import Amazonka.Core hiding (error)
+import Amazonka.S3.Encryption.Encrypt
+import Amazonka.S3.Encryption.Types
+import Control.Exception (ErrorCall (..), evaluate, try)
+import Test.Amazonka.S3.Encryption.Envelope (mkTestAESV2Envelope)
+import Test.Tasty (TestTree, testGroup)
+import Test.Tasty.HUnit (assertEqual, assertFailure, testCase)
+import Prelude
+
+encryptTests :: TestTree
+encryptTests =
+  testGroup
+    "encrypt"
+    [testCase "preserves response evaluation policy" testResponseEvaluation]
+
+data EvaluationProbe = EvaluationProbe
+
+newtype EvaluationResponse = EvaluationResponse Int
+
+instance AWSRequest EvaluationProbe where
+  type AWSResponse EvaluationProbe = EvaluationResponse
+
+  evaluateResponse _ (EvaluationResponse value) = value `seq` ()
+
+  request = error "request is not used by this test"
+
+  response = error "response is not used by this test"
+
+testResponseEvaluation :: IO ()
+testResponseEvaluation = do
+  let encryptedRequest = Encrypted EvaluationProbe [] Discard mkTestAESV2Envelope
+      evaluationResponse = EvaluationResponse (error "encrypted response was forced")
+  result <-
+    try (evaluate (evaluateResponse encryptedRequest evaluationResponse)) ::
+      IO (Either ErrorCall ())
+  case result of
+    Left (ErrorCall exceptionMessage) ->
+      assertEqual "unexpected evaluation exception" "encrypted response was forced" exceptionMessage
+    Right () -> assertFailure "expected the wrapped response policy to be used"

lib/amazonka-s3-encryption/test/Test/Amazonka/S3/Encryption/Envelope.hs

@@ -2,7 +2,11 @@
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 
-module Test.Amazonka.S3.Encryption.Envelope (envelopeTests) where
+module Test.Amazonka.S3.Encryption.Envelope
+  ( envelopeTests,
+    mkTestAESV2Envelope,
+  )
+where
 
 import Amazonka.Core
 import Amazonka.S3.Encryption.Envelope

lib/amazonka/CHANGELOG.md

@@ -99,6 +99,10 @@
 
 ### Fixed
 
+- `amazonka`: Fully evaluate successful non-streaming service responses before
+  returning them from send operations or passing them to waiter acceptors.
+  Streaming response bodies remain lazy.
+  [\#1050](https://github.com/brendanhay/amazonka/pull/1050)
 - `amazonka`: `Amazonka.Auth.SSO.relativeCachedTokenFile` is now pure
 [\#1056](https://github.com/brendanhay/amazonka/pull/1056)
 - `amazonka-core`: `containers ^>= 0.7` is now supported. `containers-0.7` is shipped with GHC 9.10 and 9.12.

lib/amazonka/amazonka.cabal

@@ -122,16 +122,24 @@ library
     , uuid                  >=1.2.6     && <1.4
 
 test-suite tests
-  import:         base
-  type:           exitcode-stdio-1.0
-  hs-source-dirs: test
-  main-is:        Main.hs
-  other-modules:  Test.Amazonka.Auth.Background
+  import:            base
+  type:              exitcode-stdio-1.0
+  hs-source-dirs:    test
+  main-is:           Main.hs
+  other-modules:
+    Test.Amazonka.Auth.Background
+    Test.Amazonka.Send
   build-depends:
     , amazonka
     , amazonka-core
+    , amazonka-sts
+    , bytestring
+    , conduit
+    , deepseq
+    , network
+    , resourcet
+    , tasty              >=0.10
+    , tasty-hunit        >=0.9
+    , time
     , http-client
     , http-types
-    , tasty          >=0.10
-    , tasty-hunit    >=0.9
-    , time

lib/amazonka/src/Amazonka/HTTP.hs

@@ -28,6 +28,7 @@ import Control.Monad.Trans.Resource (liftResourceT, transResourceT)
 import qualified Control.Retry as Retry
 import Data.Foldable (traverse_)
 import qualified Data.Time as Time
+import qualified Network.HTTP.Client as Client
 import qualified Network.HTTP.Conduit as Client.Conduit
 
 retryRequest ::
@@ -67,7 +68,7 @@ retryRequest env@Env {hooks} rq = do
 
   Retry.retrying policy shouldRetry attempt >>= \case
     Left e -> Left e <$ liftIO (Hooks.error hooks env (Final, cfgRq, e))
-    Right a -> pure $ Right a
+    Right a -> Right a <$ evaluateSuccessfulResponse rq' a
 
 awaitRequest ::
   ( MonadResource m,
@@ -84,7 +85,10 @@ awaitRequest env@Env {hooks} w rq = do
   w'@Wait {..} <- liftIO $ Hooks.wait hooks env w
 
   let handleResult res = (fromMaybe AcceptRetry $ accept w' cfgRq res, res)
-      attempt _ = handleResult <$> httpRequest env cfgRq
+      attempt _ = do
+        result <- httpRequest env cfgRq
+        traverse_ (evaluateSuccessfulResponse rq') result
+        pure (handleResult result)
       policy =
         Retry.limitRetries attempts
           <> Retry.constantDelay (toMicroseconds delay)
@@ -147,6 +151,17 @@ httpRequest env@Env {hooks, manager, region} cfgRq =
     proxy :: Request a -> Proxy a
     proxy _ = Proxy
 
+evaluateSuccessfulResponse ::
+  (MonadIO m, AWSRequest a) =>
+  a ->
+  ClientResponse (AWSResponse a) ->
+  m ()
+evaluateSuccessfulResponse rq =
+  liftIO
+    . Exception.evaluate
+    . evaluateResponse rq
+    . Client.responseBody
+
 -- Configures an AWS request `a` into its `Request a` form, applying
 -- service overrides from `env` and running hooks on the configured
 -- (Request a).

lib/amazonka/src/Amazonka/Send.hs

@@ -29,8 +29,8 @@ sendEither ::
   Env ->
   a ->
   m (Either Error (AWSResponse a))
-sendEither env =
-  fmap (second Client.responseBody) . HTTP.retryRequest env
+sendEither env rq =
+  fmap Client.responseBody <$> HTTP.retryRequest env rq
 
 -- | Send a request, returning the associated response if successful.
 --
@@ -59,8 +59,8 @@ sendUnsignedEither ::
   Env' withAuth ->
   a ->
   m (Either Error (AWSResponse a))
-sendUnsignedEither env =
-  fmap (second Client.responseBody) . HTTP.retryRequest (env {auth = Proxy})
+sendUnsignedEither env rq =
+  fmap Client.responseBody <$> HTTP.retryRequest (env {auth = Proxy}) rq
 
 -- | Make an unsigned request, returning the associated response if successful.
 --

lib/amazonka/test/Main.hs

@@ -1,8 +1,9 @@
 module Main (main) where
 
 import qualified Test.Amazonka.Auth.Background as AuthBackground
+import qualified Test.Amazonka.Send as Send
 import Test.Tasty (defaultMain, testGroup)
 import Prelude
 
 main :: IO ()
-main = defaultMain (testGroup "amazonka" [AuthBackground.tests])
+main = defaultMain (testGroup "amazonka" [AuthBackground.tests, Send.tests])