diff --git a/amazonka.cabal b/amazonka.cabal --- a/amazonka.cabal +++ b/amazonka.cabal @@ -1,5 +1,5 @@ name: amazonka -version: 0.0.4 +version: 0.0.5 synopsis: Comprehensive Amazon Web Services SDK homepage: https://github.com/brendanhay/amazonka license: OtherLicense @@ -33,17 +33,21 @@ Control.Monad.Trans.AWS , Network.AWS + other-modules: + Network.AWS.Internal.Log + build-depends: - amazonka-core == 0.0.4.* + amazonka-core == 0.0.5.* , base >= 4.7 && < 5 + , bytestring >= 0.9 , conduit >= 1.1 && < 1.3 , exceptions == 0.6.* - , http-conduit >= 2.1.4 && < 2.2 + , http-conduit >= 2.1.4 && < 2.3 , lens >= 4.4 && < 5 , mmorph >= 1 && < 2 , monad-control >= 0.3.2 && < 4 , mtl >= 2.2.1 && < 2.3 , resourcet >= 1.1 && < 1.3 - , text >= 1.1 , time >= 1.4 + , transformers == 0.4.* , transformers-base >= 0.4.2 diff --git a/src/Control/Monad/Trans/AWS.hs b/src/Control/Monad/Trans/AWS.hs --- a/src/Control/Monad/Trans/AWS.hs +++ b/src/Control/Monad/Trans/AWS.hs @@ -37,15 +37,18 @@ , envRegion , envManager , envLogger - , scoped -- ** Creating the environment , Credentials (..) , AWS.newEnv , AWS.getEnv - -- * Debugging - , debug - , whenDebug + -- * Logging + , LogLevel (..) + , Logger + , newLogger + , logInfo + , logDebug + , logTrace -- * Regionalisation , Region (..) @@ -70,6 +73,7 @@ , presign -- * Types + , ToBuilder (..) , module Network.AWS.Types ) where @@ -84,13 +88,13 @@ import Control.Monad.Trans.Control import Control.Monad.Trans.Resource import Data.Conduit -import Data.Text (Text) import Data.Time import Network.AWS (Env, envRegion, envLogger, envAuth, envManager) import qualified Network.AWS as AWS import Network.AWS.Auth -import qualified Network.AWS.Types as Types -import Network.AWS.Types hiding (debug) +import Network.AWS.Data (ToBuilder(..)) +import Network.AWS.Internal.Log +import Network.AWS.Types -- | The top-level error type. type Error = ServiceError String @@ -111,7 +115,7 @@ -- | The transformer. This satisfies all of the constraints that the functions -- in this module require, such as providing 'MonadResource' instances, --- as well as keeping track of the internal 'Env' environment. +-- and keeping track of the 'Env' environment. -- -- The 'MonadError' instance for this transformer internally uses 'ExceptT' -- to handle actions that result in an 'Error'. For more information see @@ -225,19 +229,17 @@ scoped :: MonadReader Env m => (Env -> m a) -> m a scoped f = ask >>= f --- | Use the logger from 'envLogger' to log a debug message. -debug :: (MonadIO m, MonadReader Env m) => Text -> m () -debug t = view envLogger >>= (`Types.debug` t) +-- | Use the supplied logger from 'envLogger' to log info messages. +logInfo :: (MonadIO m, MonadReader Env m, ToBuilder a) => a -> m () +logInfo x = view envLogger >>= (`info` x) --- | Perform a monadic action if 'envLogger' is set to 'Debug'. --- --- Analogous to 'when'. -whenDebug :: MonadReader Env m => m () -> m () -whenDebug f = do - l <- view envLogger - case l of - Debug _ -> f - _ -> return () +-- | Use the supplied logger from 'envLogger' to log debug messages. +logDebug :: (MonadIO m, MonadReader Env m, ToBuilder a) => a -> m () +logDebug x = view envLogger >>= (`debug` x) + +-- | Use the supplied logger from 'envLogger' to log trace messages. +logTrace :: (MonadIO m, MonadReader Env m, ToBuilder a) => a -> m () +logTrace x = view envLogger >>= (`trace` x) -- | Scope a monadic action within the specific 'Region'. within :: MonadReader Env m => Region -> m a -> m a diff --git a/src/Network/AWS.hs b/src/Network/AWS.hs --- a/src/Network/AWS.hs +++ b/src/Network/AWS.hs @@ -30,6 +30,11 @@ , newEnv , getEnv + -- * Logging + , LogLevel (..) + , Logger + , newLogger + -- * Requests -- ** Synchronous , send @@ -47,10 +52,10 @@ import Control.Monad.Except import Control.Monad.Trans.Resource import Data.Conduit -import Data.Monoid import Data.Time import Network.AWS.Auth import Network.AWS.Data +import Network.AWS.Internal.Log import qualified Network.AWS.Signing.Internal as Sign import Network.AWS.Types import Network.HTTP.Conduit hiding (Response) @@ -74,7 +79,7 @@ -> Credentials -> Manager -> ExceptT String m Env -newEnv r c m = Env r None m `liftM` getAuth m c +newEnv r c m = Env r (\_ _ -> return ()) m `liftM` getAuth m c -- | Create a new environment without debug logging, creating a new 'Manager'. -- @@ -102,15 +107,17 @@ send Env{..} x@(request -> rq) = go `catch` er >>= response x where go = do - debug _envLogger $ - "[Raw Request]\n" <> toText rq + trace _envLogger (build rq) + t <- liftIO getCurrentTime - s <- Sign.sign _envAuth _envRegion rq t - debug _envLogger $ - "[Signed Request]\n" <> toText s - rs <- liftResourceT (http (s^.sgRequest) _envManager) - debug _envLogger $ - "[Raw Response]\n" <> toText rs + + Signed m s <- Sign.sign _envAuth _envRegion rq t + debug _envLogger (build s) + trace _envLogger (build m) + + rs <- liftResourceT (http s _envManager) + debug _envLogger (build rs) + return (Right rs) er ex = return (Left (ex :: HttpException)) diff --git a/src/Network/AWS/Internal/Log.hs b/src/Network/AWS/Internal/Log.hs new file mode 100644 --- /dev/null +++ b/src/Network/AWS/Internal/Log.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE MultiWayIf #-} + +-- Module : Network.AWS.Internal.Log +-- Copyright : (c) 2013-2014 Brendan Hay +-- License : This Source Code Form is subject to the terms of +-- the Mozilla Public License, v. 2.0. +-- A copy of the MPL can be found in the LICENSE file or +-- you can obtain it at http://mozilla.org/MPL/2.0/. +-- Maintainer : Brendan Hay +-- Stability : experimental +-- Portability : non-portable (GHC extensions) + +-- | Types and functions for optional logging machinery used during the +-- request, response, and signing life-cycles. +module Network.AWS.Internal.Log where + +import Control.Monad.IO.Class +import Data.ByteString.Builder +import Data.Monoid +import Network.AWS.Data +import System.IO + +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 () + +-- | This is a primitive logger which can be used to log messages to a 'Handle'. +-- A more sophisticated logging library such as tinylog or FastLogger should be +-- used in production code. +newLogger :: MonadIO m => LogLevel -> Handle -> m Logger +newLogger x hd = liftIO $ do + hSetBinaryMode hd True + hSetBuffering hd LineBuffering -- ^ Should be BlockBuffering, but .. concurrency. + return $ \y b -> + if x >= y + then hPutBuilder hd (b <> "\n") + else return () + +info :: (MonadIO m, ToBuilder a) => Logger -> a -> m () +info f = liftIO . f Info . build +{-# INLINE info #-} + +debug :: (MonadIO m, ToBuilder a) => Logger -> a -> m () +debug f = liftIO . f Debug . build +{-# INLINE debug #-} + +trace :: (MonadIO m, ToBuilder a) => Logger -> a -> m () +trace f = liftIO . f Trace . build +{-# INLINE trace #-}