Merge pull request aristidb#213 from bgamari/http-client-2.2

Support http-client == 2.2

Author: aristidb

Aws/Aws.hs

@@ -52,6 +52,7 @@ import qualified Data.Text.Encoding           as T
 import qualified Data.Text.IO                 as T
 import qualified Network.HTTP.Conduit         as HTTP
 import           System.IO                    (stderr)
+import           Prelude
 
 -- | The severity of a log message, in rising order.
 data LogLevel
@@ -189,9 +190,9 @@ simpleAws :: (Transaction r a, AsMemoryResponse a, MonadIO io)
             -> ServiceConfiguration r NormalQuery
             -> r
             -> io (MemoryResponse a)
-simpleAws cfg scfg request
-  = liftIO $ HTTP.withManager $ \manager ->
-      loadToMemory =<< readResponseIO =<< aws cfg scfg manager request
+simpleAws cfg scfg request = liftIO $ runResourceT $ do
+    manager <- liftIO $ HTTP.newManager HTTP.tlsManagerSettings
+    loadToMemory =<< readResponseIO =<< aws cfg scfg manager request
 
 -- | Run an AWS transaction, without enforcing that response and request type form a valid transaction pair.
 --
@@ -202,7 +203,6 @@ simpleAws cfg scfg request
 -- Metadata is wrapped in the Response, and also logged at level 'Info'.
 unsafeAws
   :: (ResponseConsumer r a,
-      Monoid (ResponseMetadata a),
       Loggable (ResponseMetadata a),
       SignQuery r) =>
      Configuration -> ServiceConfiguration r NormalQuery -> HTTP.Manager -> r -> ResourceT IO (Response (ResponseMetadata a) a)
@@ -227,7 +227,6 @@ unsafeAws cfg scfg manager request = do
 -- Metadata is put in the 'IORef', but not logged.
 unsafeAwsRef
   :: (ResponseConsumer r a,
-      Monoid (ResponseMetadata a),
       SignQuery r) =>
      Configuration -> ServiceConfiguration r NormalQuery -> HTTP.Manager -> IORef (ResponseMetadata a) -> r -> ResourceT IO a
 unsafeAwsRef cfg info manager metadataRef request = do
@@ -247,7 +246,7 @@ unsafeAwsRef cfg info manager metadataRef request = do
   logDebug $ "Response status: " ++ show (HTTP.responseStatus hresp)
   forM_ (HTTP.responseHeaders hresp) $ \(hname,hvalue) -> liftIO $
     logger cfg Debug $ T.decodeUtf8 $ "Response header '" `mappend` CI.original hname `mappend` "': '" `mappend` hvalue `mappend` "'"
-  {-# SCC "unsafeAwsRef:responseConsumer" #-} responseConsumer request metadataRef hresp
+  {-# SCC "unsafeAwsRef:responseConsumer" #-} responseConsumer httpRequest request metadataRef hresp
 
 -- | Run a URI-only AWS transaction. Returns a URI that can be sent anywhere. Does not work with all requests.
 --

Aws/Core.hs

@@ -22,6 +22,7 @@ module Aws.Core
 , HeaderException(..)
 , FormException(..)
 , NoCredentialsException(..)
+, throwStatusCodeException
   -- ** Response deconstruction helpers
 , readHex2
   -- *** XML
@@ -111,8 +112,10 @@ import qualified Data.ByteString.UTF8     as BU
 import           Data.Char
 import           Data.Conduit             (($$+-))
 import qualified Data.Conduit             as C
+#if MIN_VERSION_http_conduit(2,2,0)
+import qualified Data.Conduit.Binary      as CB
+#endif
 import qualified Data.Conduit.List        as CL
-import           Data.Default             (def)
 import           Data.IORef
 import           Data.List
 import qualified Data.Map                 as M
@@ -130,14 +133,13 @@ import qualified Network.HTTP.Types       as HTTP
 import           System.Directory
 import           System.Environment
 import           System.FilePath          ((</>))
-#if MIN_VERSION_time(1,5,0)
-import           Data.Time.Format
-#else
+#if !MIN_VERSION_time(1,5,0)
 import           System.Locale
 #endif
 import qualified Text.XML                 as XML
 import qualified Text.XML.Cursor          as Cu
 import           Text.XML.Cursor          hiding (force, forceM)
+import           Prelude
 -------------------------------------------------------------------------------
 
 -- | Types that can be logged (textually).
@@ -201,14 +203,15 @@ class Monoid (ResponseMetadata resp) => ResponseConsumer req resp where
     -- metadata type for each AWS service.
     type ResponseMetadata resp
 
-    -- | Response parser. Takes the corresponding request, an 'IORef'
-    -- for metadata, and HTTP response data.
-    responseConsumer :: req -> IORef (ResponseMetadata resp) -> HTTPResponseConsumer resp
+    -- | Response parser. Takes the corresponding AWS request, the derived
+    -- @http-client@ request (for error reporting), an 'IORef' for metadata, and
+    -- HTTP response data.
+    responseConsumer :: HTTP.Request -> req -> IORef (ResponseMetadata resp) -> HTTPResponseConsumer resp
 
 -- | Does not parse response. For debugging.
 instance ResponseConsumer r (HTTP.Response L.ByteString) where
     type ResponseMetadata (HTTP.Response L.ByteString) = ()
-    responseConsumer _ _ resp = do
+    responseConsumer _ _ _ resp = do
         bss <- HTTP.responseBody resp $$+- CL.consume
         return resp
             { HTTP.responseBody = L.fromChunks bss
@@ -317,8 +320,8 @@ loadCredentialsFromEnv = liftIO $ do
   Traversable.sequence $ makeCredentials' <$> keyID <*> secret
 
 loadCredentialsFromInstanceMetadata :: MonadIO io => io (Maybe Credentials)
-loadCredentialsFromInstanceMetadata = liftIO $ HTTP.withManager $ \mgr ->
-  do
+loadCredentialsFromInstanceMetadata = do
+    mgr <- liftIO $ HTTP.newManager HTTP.tlsManagerSettings
     -- check if the path is routable
     avail <- liftIO $ hostAvailable "169.254.169.254"
     if not avail
@@ -462,7 +465,7 @@ queryToHttpRequest :: SignedQuery -> IO (HTTP.Request (C.ResourceT IO))
 #endif
 queryToHttpRequest SignedQuery{..} =  do
     mauth <- maybe (return Nothing) (Just<$>) sqAuthorization
-    return $ def {
+    return $ HTTP.defaultRequest {
         HTTP.method = httpMethod sqMethod
       , HTTP.secure = case sqProtocol of
                         HTTP -> False
@@ -494,7 +497,11 @@ queryToHttpRequest SignedQuery{..} =  do
               _         -> HTTP.RequestBodyBuilder 0 mempty
 
       , HTTP.decompress = HTTP.alwaysDecompress
-      , HTTP.checkStatus = \_ _ _ -> Nothing
+#if MIN_VERSION_http_conduit(2,2,0)
+      , HTTP.checkResponse = \_ _ -> return ()
+#else
+      , HTTP.checkStatus = \_ _ _-> Nothing
+#endif
 
       , HTTP.redirectCount = 10
       }
@@ -792,6 +799,24 @@ newtype NoCredentialsException = NoCredentialsException { noCredentialsErrorMess
 
 instance E.Exception NoCredentialsException
 
+-- | A helper to throw an 'HTTP.StatusCodeException'.
+throwStatusCodeException :: HTTP.Request
+                         -> HTTP.Response (C.ResumableSource (ResourceT IO) ByteString)
+                         -> ResourceT IO a
+#if MIN_VERSION_http_conduit(2,2,0)
+throwStatusCodeException req resp = do
+    let resp' = fmap (const ()) resp
+    -- only take first 10kB of error response
+    body <- HTTP.responseBody resp C.$$+- CB.take (10*1024)
+    let sce = HTTP.StatusCodeException resp' (L.toStrict body)
+    throwM $ HTTP.HttpExceptionRequest req sce
+#else
+throwStatusCodeException _req resp = do
+    let cookies = HTTP.responseCookieJar resp
+        headers = HTTP.responseHeaders   resp
+        status  = HTTP.responseStatus    resp
+    throwM $ HTTP.StatusCodeException status headers cookies
+#endif
 
 -- | A specific element (case-insensitive, ignoring namespace - sadly necessary), extracting only the textual contents.
 elContent :: T.Text -> Cursor -> [T.Text]

Aws/DynamoDb/Commands/DeleteItem.hs

@@ -26,6 +26,7 @@ import           Control.Applicative
 import           Data.Aeson
 import           Data.Default
 import qualified Data.Text           as T
+import           Prelude
 -------------------------------------------------------------------------------
 import           Aws.Core
 import           Aws.DynamoDb.Core
@@ -97,7 +98,7 @@ instance FromJSON DeleteItemResponse where
 
 instance ResponseConsumer r DeleteItemResponse where
     type ResponseMetadata DeleteItemResponse = DdbResponse
-    responseConsumer _ ref resp = ddbResponseConsumer ref resp
+    responseConsumer _ _ ref resp = ddbResponseConsumer ref resp
 
 
 instance AsMemoryResponse DeleteItemResponse where

Aws/DynamoDb/Commands/GetItem.hs

@@ -19,6 +19,7 @@ import           Control.Applicative
 import           Data.Aeson
 import           Data.Default
 import qualified Data.Text           as T
+import           Prelude
 -------------------------------------------------------------------------------
 import           Aws.Core
 import           Aws.DynamoDb.Core
@@ -84,7 +85,7 @@ instance FromJSON GetItemResponse where
 
 instance ResponseConsumer r GetItemResponse where
     type ResponseMetadata GetItemResponse = DdbResponse
-    responseConsumer _ ref resp = ddbResponseConsumer ref resp
+    responseConsumer _ _ ref resp = ddbResponseConsumer ref resp
 
 
 instance AsMemoryResponse GetItemResponse where

Aws/DynamoDb/Commands/PutItem.hs

@@ -26,6 +26,7 @@ import           Control.Applicative
 import           Data.Aeson
 import           Data.Default
 import qualified Data.Text           as T
+import           Prelude
 -------------------------------------------------------------------------------
 import           Aws.Core
 import           Aws.DynamoDb.Core
@@ -98,7 +99,7 @@ instance FromJSON PutItemResponse where
 
 instance ResponseConsumer r PutItemResponse where
     type ResponseMetadata PutItemResponse = DdbResponse
-    responseConsumer _ ref resp = ddbResponseConsumer ref resp
+    responseConsumer _ _ ref resp = ddbResponseConsumer ref resp
 
 
 instance AsMemoryResponse PutItemResponse where

Aws/DynamoDb/Commands/Query.hs

@@ -135,7 +135,8 @@ instance SignQuery Query where
 
 instance ResponseConsumer r QueryResponse where
     type ResponseMetadata QueryResponse = DdbResponse
-    responseConsumer _ ref resp = ddbResponseConsumer ref resp
+    responseConsumer _ _ ref resp
+        = ddbResponseConsumer ref resp
 
 
 instance AsMemoryResponse QueryResponse where

Aws/DynamoDb/Commands/Scan.hs

@@ -114,7 +114,7 @@ instance SignQuery Scan where
 
 instance ResponseConsumer r ScanResponse where
     type ResponseMetadata ScanResponse = DdbResponse
-    responseConsumer _ ref resp = ddbResponseConsumer ref resp
+    responseConsumer _ _ ref resp = ddbResponseConsumer ref resp
 
 
 instance AsMemoryResponse ScanResponse where

Aws/DynamoDb/Commands/Table.hs

@@ -44,6 +44,7 @@ import           Data.Time.Clock.POSIX
 import           Data.Typeable
 import qualified Data.Vector           as V
 import           GHC.Generics          (Generic)
+import           Prelude
 -------------------------------------------------------------------------------
 import           Aws.Core
 import           Aws.DynamoDb.Core
@@ -293,7 +294,7 @@ instance A.FromJSON TableDescription where
 {- Can't derive these instances onto the return values
 instance ResponseConsumer r TableDescription where
     type ResponseMetadata TableDescription = DyMetadata
-    responseConsumer _ _ = ddbResponseConsumer
+    responseConsumer _ _ _ = ddbResponseConsumer
 instance AsMemoryResponse TableDescription where
     type MemoryResponse TableDescription = TableDescription
     loadToMemory = return
@@ -351,7 +352,7 @@ newtype CreateTableResult = CreateTableResult { ctStatus :: TableDescription }
 -- ResponseConsumer and AsMemoryResponse can't be derived
 instance ResponseConsumer r CreateTableResult where
     type ResponseMetadata CreateTableResult = DdbResponse
-    responseConsumer _ = ddbResponseConsumer
+    responseConsumer _ _ = ddbResponseConsumer
 instance AsMemoryResponse CreateTableResult where
     type MemoryResponse CreateTableResult = TableDescription
     loadToMemory = return . ctStatus
@@ -376,7 +377,7 @@ newtype DescribeTableResult = DescribeTableResult { dtStatus :: TableDescription
 -- ResponseConsumer can't be derived
 instance ResponseConsumer r DescribeTableResult where
     type ResponseMetadata DescribeTableResult = DdbResponse
-    responseConsumer _ = ddbResponseConsumer
+    responseConsumer _ _ = ddbResponseConsumer
 instance AsMemoryResponse DescribeTableResult where
     type MemoryResponse DescribeTableResult = TableDescription
     loadToMemory = return . dtStatus
@@ -408,7 +409,7 @@ newtype UpdateTableResult = UpdateTableResult { uStatus :: TableDescription }
 -- ResponseConsumer can't be derived
 instance ResponseConsumer r UpdateTableResult where
     type ResponseMetadata UpdateTableResult = DdbResponse
-    responseConsumer _ = ddbResponseConsumer
+    responseConsumer _ _ = ddbResponseConsumer
 instance AsMemoryResponse UpdateTableResult where
     type MemoryResponse UpdateTableResult = TableDescription
     loadToMemory = return . uStatus
@@ -433,7 +434,7 @@ newtype DeleteTableResult = DeleteTableResult { dStatus :: TableDescription }
 -- ResponseConsumer can't be derived
 instance ResponseConsumer r DeleteTableResult where
     type ResponseMetadata DeleteTableResult = DdbResponse
-    responseConsumer _ = ddbResponseConsumer
+    responseConsumer _ _ = ddbResponseConsumer
 instance AsMemoryResponse DeleteTableResult where
     type MemoryResponse DeleteTableResult = TableDescription
     loadToMemory = return . dStatus
@@ -459,7 +460,7 @@ instance A.FromJSON ListTablesResult where
     parseJSON = A.genericParseJSON capitalizeOpt
 instance ResponseConsumer r ListTablesResult where
     type ResponseMetadata ListTablesResult = DdbResponse
-    responseConsumer _ = ddbResponseConsumer
+    responseConsumer _ _ = ddbResponseConsumer
 instance AsMemoryResponse ListTablesResult where
     type MemoryResponse ListTablesResult = [T.Text]
     loadToMemory = return . tableNames

Aws/DynamoDb/Commands/UpdateItem.hs

@@ -25,7 +25,6 @@ module Aws.DynamoDb.Commands.UpdateItem
     , AttributeUpdate(..)
     , au
     , UpdateAction(..)
-    , UpdateItem(..)
     , UpdateItemResponse(..)
     ) where
 
@@ -34,6 +33,7 @@ import           Control.Applicative
 import           Data.Aeson
 import           Data.Default
 import qualified Data.Text           as T
+import           Prelude
 -------------------------------------------------------------------------------
 import           Aws.Core
 import           Aws.DynamoDb.Core
@@ -158,7 +158,7 @@ instance FromJSON UpdateItemResponse where
 
 instance ResponseConsumer r UpdateItemResponse where
     type ResponseMetadata UpdateItemResponse = DdbResponse
-    responseConsumer _ ref resp = ddbResponseConsumer ref resp
+    responseConsumer _ _ ref resp = ddbResponseConsumer ref resp
 
 
 instance AsMemoryResponse UpdateItemResponse where

Aws/DynamoDb/Core.hs

@@ -399,7 +399,7 @@ instance DynVal UTCTime where
 
 -------------------------------------------------------------------------------
 pico :: Rational
-pico = toRational $ 10 ^ (12 :: Integer)
+pico = toRational $ (10 :: Integer) ^ (12 :: Integer)
 
 
 -------------------------------------------------------------------------------
@@ -1142,6 +1142,7 @@ data QuerySelect
 instance Default QuerySelect where def = SelectAll
 
 -------------------------------------------------------------------------------
+querySelectJson :: KeyValue t => QuerySelect -> [t]
 querySelectJson (SelectSpecific as) =
     [ "Select" .= String "SPECIFIC_ATTRIBUTES"
     , "AttributesToGet" .= as]
@@ -1338,7 +1339,7 @@ getAttr k m = do
 -- | Parse attribute if it's present in the 'Item'. Fail if attribute
 -- is present but conversion fails.
 getAttr'
-    :: forall a. (Typeable a, DynVal a)
+    :: forall a. (DynVal a)
     => T.Text
     -- ^ Attribute name
     -> Item