Adding debug logging of XML/JSON response bodies

mookerji · Dec 22, 2014 · 8720580 · 8720580
1 parent 652c2b0
commit 8720580
Show file tree

Hide file tree

Showing 2 changed files with 33 additions and 7 deletions.
diff --git a/core/src/Network/AWS/Response.hs b/core/src/Network/AWS/Response.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE FlexibleContexts    #-}
+{-# LANGUAGE OverloadedStrings   #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TupleSections       #-}
 {-# LANGUAGE TypeFamilies        #-}
@@ -27,59 +28,67 @@ module Network.AWS.Response
 
 import           Control.Applicative
 import           Control.Monad
+import           Control.Monad.IO.Class
 import           Control.Monad.Trans.Resource
 import           Data.Aeson
 import           Data.Bifunctor
 import qualified Data.ByteString.Lazy         as LBS
 import           Data.Conduit
 import qualified Data.Conduit.Binary          as Conduit
-import           Network.AWS.Data             (LazyByteString, FromXML(..), decodeXML)
+import           Data.Monoid
+import           Network.AWS.Data             (LazyByteString, FromXML(..), decodeXML, build)
 import           Network.AWS.Types
 import           Network.HTTP.Client          hiding (Request, Response)
 import           Network.HTTP.Types
 import           Text.XML                     (Node)
 
 nullResponse :: (MonadResource m, AWSService (Sv a))
              => Rs a
+             -> Logger
              -> Request a
              -> Either HttpException ClientResponse
              -> m (Response' a)
-nullResponse rs = receive $ \_ _ bdy ->
+nullResponse rs _ = receive $ \_ _ bdy ->
     liftResourceT (bdy $$+- return (Right rs))
 {-# INLINE nullResponse #-}
 
 headerResponse :: (MonadResource m, AWSService (Sv a))
                => (ResponseHeaders -> Either String (Rs a))
+               -> Logger
                -> Request a
                -> Either HttpException ClientResponse
                -> m (Response' a)
 headerResponse f = deserialise (const (Right ())) (const . f)
 {-# INLINE headerResponse #-}
 
 xmlResponse :: (MonadResource m, AWSService (Sv a), FromXML (Rs a))
-            => Request a
+            => Logger
+            -> Request a
             -> Either HttpException ClientResponse
             -> m (Response' a)
 xmlResponse = deserialise (decodeXML >=> parseXML) (const Right)
 {-# INLINE xmlResponse #-}
 
 xmlHeaderResponse :: (MonadResource m, AWSService (Sv a))
                   => (ResponseHeaders -> [Node] -> Either String (Rs a))
+                  -> Logger
                   -> Request a
                   -> Either HttpException ClientResponse
                   -> m (Response' a)
 xmlHeaderResponse = deserialise decodeXML
 {-# INLINE xmlHeaderResponse #-}
 
 jsonResponse :: (MonadResource m, AWSService (Sv a), FromJSON (Rs a))
-             => Request a
+             => Logger
+             -> Request a
              -> Either HttpException ClientResponse
              -> m (Response' a)
 jsonResponse = deserialise eitherDecode' (const Right)
 {-# INLINE jsonResponse #-}
 
 jsonHeaderResponse :: (MonadResource m, AWSService (Sv a))
                    => (ResponseHeaders -> Object -> Either String (Rs a))
+                   -> Logger
                    -> Request a
                    -> Either HttpException ClientResponse
                    -> m (Response' a)
@@ -88,21 +97,24 @@ jsonHeaderResponse = deserialise eitherDecode'
 
 bodyResponse :: (MonadResource m, AWSService (Sv a))
              => (ResponseHeaders -> ResponseBody -> Either String (Rs a))
+             -> Logger
              -> Request a
              -> Either HttpException ClientResponse
              -> m (Response' a)
-bodyResponse f = receive $ \a hs bdy ->
+bodyResponse f _ = receive $ \a hs bdy ->
     return (SerializerError a `first` f hs bdy)
 {-# INLINE bodyResponse #-}
 
 deserialise :: (AWSService (Sv a), MonadResource m)
             => (LazyByteString -> Either String b)
             -> (ResponseHeaders -> b -> Either String (Rs a))
+            -> Logger
             -> Request a
             -> Either HttpException ClientResponse
             -> m (Response' a)
-deserialise g f = receive $ \a hs bdy -> do
+deserialise g f l = receive $ \a hs bdy -> do
     lbs <- sinkLbs bdy
+    liftIO $ l Debug ("[Client Response Body]\n" <> build lbs)
     return $! case g lbs of
         Left  e -> Left (SerializerError a e)
         Right o ->

diff --git a/core/src/Network/AWS/Types.hs b/core/src/Network/AWS/Types.hs
@@ -79,6 +79,10 @@ module Network.AWS.Types
     , Response'
     , Empty         (..)
 
+    -- * Logging
+    , LogLevel      (..)
+    , Logger
+
     -- * Regions
     , Region        (..)
 
@@ -101,6 +105,7 @@ import           Control.Monad.Trans.Resource
 import           Data.Aeson                   hiding (Error)
 import           Data.ByteString              (ByteString)
 import qualified Data.ByteString              as BS
+import           Data.ByteString.Builder      (Builder)
 import qualified Data.CaseInsensitive         as CI
 import           Data.Conduit
 import           Data.Default.Class
@@ -163,6 +168,14 @@ type Response  a = Either (ServiceError (Er (Sv a))) (Rs a)
 
 type Response' a = Either (ServiceError (Er (Sv a))) (Status, Rs a)
 
+data LogLevel
+    = Info  -- ^ Informational messages supplied by the user, not used by the library.
+    | Debug -- ^ Info level + debug messages + non-streaming response bodies.
+    | Trace -- ^ Debug level + potentially sensitive signing metadata.
+      deriving (Eq, Ord, Enum, Show)
+
+type Logger = LogLevel -> Builder -> IO ()
+
 -- | Specify how a request can be de/serialised.
 class (AWSService (Sv a), AWSSigner (Sg (Sv a))) => AWSRequest a where
     -- | The service definition for a request.
@@ -173,7 +186,8 @@ class (AWSService (Sv a), AWSSigner (Sg (Sv a))) => AWSRequest a where
 
     request  :: a -> Request a
     response :: MonadResource m
-             => Request a
+             => Logger
+             -> Request a
              -> Either HttpException ClientResponse
              -> m (Response' a)