diff --git a/amazonka.cabal b/amazonka.cabal --- a/amazonka.cabal +++ b/amazonka.cabal @@ -1,5 +1,5 @@ name: amazonka -version: 0.0.7 +version: 0.0.8 synopsis: Comprehensive Amazon Web Services SDK homepage: https://github.com/brendanhay/amazonka license: OtherLicense @@ -32,14 +32,15 @@ exposed-modules: Control.Monad.Trans.AWS , Network.AWS - , Network.AWS.Auth other-modules: - Network.AWS.Internal.Env + Network.AWS.Internal.Auth + , Network.AWS.Internal.Env , Network.AWS.Internal.Log + , Network.AWS.Internal.Retry build-depends: - amazonka-core == 0.0.7.* + amazonka-core == 0.0.8.* , base >= 4.7 && < 5 , bytestring >= 0.9 , conduit >= 1.1 && < 1.3 @@ -50,7 +51,8 @@ , monad-control >= 0.3.2 && < 4 , mtl >= 2.2.1 && < 2.3 , resourcet >= 1.1 && < 1.3 + , retry >= 0.5 , text >= 1.1 - , time >= 1.4 + , time >= 1.5 , 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 @@ -4,7 +4,6 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} @@ -25,36 +24,62 @@ -- encapsulates various common parameters, errors, and usage patterns. module Control.Monad.Trans.AWS ( + -- * Requests + -- ** Synchronous + send + , send_ + , sendCatch + -- ** Paginated + , paginate + , paginateCatch + -- ** Eventual consistency + , await + -- ** Pre-signing URLs + , presign + , presignURL + -- * Transformer - AWS + , AWS , AWST , MonadAWS -- * Running , runAWST + -- * Regionalisation + , Region (..) + , within + + -- * Retries + , once + -- * Environment , Env - , envAuth + -- ** Lenses , envRegion - , envManager , envLogger + , envRetryCheck + , envRetryPolicy + , envManager + , envAuth -- ** Creating the environment - , Credentials (..) , AWS.newEnv , AWS.getEnv + -- ** Specifying credentials + , Credentials (..) + , fromKeys + , fromSession + , getAuth + , accessKey + , secretKey -- * Logging , LogLevel (..) , Logger , newLogger - , logInfo - , logDebug - , logTrace - - -- * Regionalisation - , Region (..) - , within + , info + , debug + , trace -- * Errors , Error @@ -63,20 +88,10 @@ , verify , verifyWith - -- * Requests - -- ** Synchronous - , send - , send_ - , sendCatch - -- ** Paginated - , paginate - , paginateCatch - -- ** Pre-signing URLs - , presign - -- * Types , ToBuilder (..) , module Network.AWS.Types + , module Network.AWS.Error ) where import Control.Applicative @@ -89,14 +104,20 @@ import Control.Monad.Reader import Control.Monad.Trans.Control import Control.Monad.Trans.Resource -import Data.Conduit +import Control.Retry (limitRetries) +import Data.ByteString (ByteString) +import Data.Conduit hiding (await) import Data.Time import qualified Network.AWS as AWS -import Network.AWS.Auth import Network.AWS.Data (ToBuilder(..)) +import Network.AWS.Error +import Network.AWS.Internal.Auth import Network.AWS.Internal.Env -import Network.AWS.Internal.Log +import qualified Network.AWS.Internal.Log as Log +import Network.AWS.Internal.Log hiding (info, debug, trace) import Network.AWS.Types +import Network.AWS.Waiters +import qualified Network.HTTP.Conduit as Client -- | The top-level error type. type Error = ServiceError String @@ -194,7 +215,7 @@ runAWST :: MonadBaseControl IO m => Env -> AWST m a -> m (Either Error a) runAWST e m = runResourceT . withInternalState $ runAWST' f . (e,) where - f = liftBase ((_envLogger e) Debug (build e)) >> m + f = liftBase (_envLogger e Debug (build e)) >> m runAWST' :: AWST m a -> (Env, InternalState) -> m (Either Error a) runAWST' (AWST k) = runExceptT . runReaderT k @@ -206,9 +227,12 @@ hoistEither :: (MonadError Error m, AWSError e) => Either e a -> m a hoistEither = either throwAWSError return +-- | Throw any 'AWSError' using 'throwError'. throwAWSError :: (MonadError Error m, AWSError e) => e -> m a throwAWSError = throwError . awsError +-- | Verify that an 'AWSError' matches the given 'Prism', otherwise throw the +-- error using 'throwAWSError'. verify :: (AWSError e, MonadError Error m) => Prism' e a -> e @@ -217,6 +241,10 @@ | isn't p e = throwAWSError e | otherwise = return () +-- | Verify that an 'AWSError' matches the given 'Prism', with an additional +-- guard on the result of the 'Prism'. +-- +-- /See:/ 'verify' verifyWith :: (AWSError e, MonadError Error m) => Prism' e a -> (a -> Bool) @@ -234,21 +262,29 @@ scoped f = ask >>= f -- | 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) +-- +-- /Note:/ By default, the library does not output 'Info' level messages. +-- Exclusive output is guaranteed via use of this function. +info :: (MonadIO m, MonadReader Env m, ToBuilder a) => a -> m () +info x = view envLogger >>= (`Log.info` x) -- | 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) +debug :: (MonadIO m, MonadReader Env m, ToBuilder a) => a -> m () +debug x = view envLogger >>= (`Log.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) +trace :: (MonadIO m, MonadReader Env m, ToBuilder a) => a -> m () +trace x = view envLogger >>= (`Log.trace` x) -- | Scope a monadic action within the specific 'Region'. within :: MonadReader Env m => Region -> m a -> m a within r = local (envRegion .~ r) +-- | Scope a monadic action such that any retry logic for the 'Service' is +-- ignored and any requests will at most be sent once. +once :: MonadReader Env m => m a -> m a +once = local (envRetryPolicy ?~ limitRetries 0) + -- | Send a data type which is an instance of 'AWSRequest', returning it's -- associated 'Rs' response type. -- @@ -256,6 +292,8 @@ -- service using the 'MonadError' instance. In the case of 'AWST' this will -- cause the internal 'ExceptT' to short-circuit and return an 'Error' in -- the 'Left' case as the result of the computation. +-- +-- /See:/ 'sendCatch' send :: ( MonadCatch m , MonadResource m , MonadReader Env m @@ -267,6 +305,8 @@ send = sendCatch >=> hoistEither -- | A variant of 'send' which discards any successful response. +-- +-- /See:/ 'send' send_ :: ( MonadCatch m , MonadResource m , MonadReader Env m @@ -283,6 +323,11 @@ -- -- This includes 'HTTPExceptions', serialisation errors, and any service -- errors returned as part of the 'Response'. +-- +-- /Note:/ Requests will be retried depending upon each service's respective +-- strategy. This can be overriden using 'once' or 'envRetry'. +-- Requests which contain streaming request bodies (such as S3's 'PutObject') are +-- never considered for retries. sendCatch :: ( MonadCatch m , MonadResource m , MonadReader Env m @@ -290,7 +335,7 @@ ) => a -> m (Response a) -sendCatch rq = scoped (`AWS.send` rq) +sendCatch x = scoped (`AWS.send` x) -- | Send a data type which is an instance of 'AWSPager' and paginate while -- there are more results as defined by the related service operation. @@ -299,6 +344,8 @@ -- -- /Note:/ The 'ResumableSource' will close when there are no more results or the -- 'ResourceT' computation is unwrapped. See: 'runResourceT' for more information. +-- +-- /See:/ 'paginateCatch' paginate :: ( MonadCatch m , MonadResource m , MonadReader Env m @@ -307,7 +354,7 @@ ) => a -> Source m (Rs a) -paginate rq = paginateCatch rq $= awaitForever (hoistEither >=> yield) +paginate x = paginateCatch x $= awaitForever (hoistEither >=> yield) -- | Send a data type which is an instance of 'AWSPager' and paginate over -- the associated 'Rs' response type in the success case, or the related service's @@ -322,10 +369,47 @@ ) => a -> Source m (Response a) -paginateCatch rq = scoped (`AWS.paginate` rq) +paginateCatch x = scoped (`AWS.paginate` x) --- | Presign a URL with expiry to be used at a later time. +-- | Poll the API until a predfined condition is fulfilled using the +-- supplied 'Wait' specification from the respective service. -- +-- Any errors which are unhandled by the 'Wait' specification during retries +-- will be thrown in the same manner as 'send'. +-- +-- /See:/ 'awaitCatch' +await :: ( MonadCatch m + , MonadResource m + , MonadReader Env m + , MonadError Error m + , AWSRequest a + ) + => Wait a + -> a + -> m (Rs a) +await w = awaitCatch w >=> hoistEither + +-- | Poll the API until a predfined condition is fulfilled using the +-- supplied 'Wait' specification from the respective service. +-- +-- The response will be either the first error returned that is not handled +-- by the specification, or the successful response from the await request. +-- +-- /Note:/ You can find any available 'Wait' specifications under the +-- namespace @Network.AWS..Waiters@ for supported services. +awaitCatch :: ( MonadCatch m + , MonadResource m + , MonadReader Env m + , AWSRequest a + ) + => Wait a + -> a + -> m (Response a) +awaitCatch w x = scoped (\e -> AWS.await e w x) + +-- | Presign an HTTP request that expires at the specified amount of time +-- in the future. +-- -- /Note:/ Requires the service's signer to be an instance of 'AWSPresigner'. -- Not all signing process support this. presign :: ( MonadIO m @@ -335,6 +419,20 @@ ) => a -- ^ Request to presign. -> UTCTime -- ^ Signing time. - -> UTCTime -- ^ Expiry time. - -> m (Signed a (Sg (Sv a))) -presign rq t x = scoped (\e -> AWS.presign e rq t x) + -> Integer -- ^ Expiry time in seconds. + -> m Client.Request +presign x t ex = scoped (\e -> AWS.presign e x t ex) + +-- | Presign a URL that expires at the specified amount of time in the future. +-- +-- /See:/ 'presign' +presignURL :: ( MonadIO m + , MonadReader Env m + , AWSRequest a + , AWSPresigner (Sg (Sv a)) + ) + => a -- ^ Request to presign. + -> UTCTime -- ^ Signing time. + -> Integer -- ^ Expiry time in seconds. + -> m ByteString +presignURL x t ex = scoped (\e -> AWS.presignURL e x t ex) diff --git a/src/Network/AWS.hs b/src/Network/AWS.hs --- a/src/Network/AWS.hs +++ b/src/Network/AWS.hs @@ -1,7 +1,9 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} @@ -18,46 +20,66 @@ -- | The core module for making requests to the various AWS services. module Network.AWS ( + -- * Requests + -- ** Synchronous + send + -- ** Paginated + , paginate + -- ** Eventual consistency + , await + -- ** Pre-signing URLs + , presign + , presignURL + -- * Environment - Env - , envAuth + , Env + -- ** Lenses , envRegion - , envManager , envLogger + , envRetryCheck + , envRetryPolicy + , envManager + , envAuth -- ** Creating the environment - , Credentials (..) , newEnv , getEnv + -- ** Specifying credentials + , Credentials (..) + , fromKeys + , fromSession + , getAuth + , accessKey + , secretKey -- * Logging , LogLevel (..) , Logger , newLogger - -- * Requests - -- ** Synchronous - , send - -- ** Paginated - , paginate - -- ** Pre-signing URLs - , presign - -- * Types , module Network.AWS.Types + , module Network.AWS.Error ) where +import Control.Applicative import Control.Monad.Catch import Control.Monad.Except import Control.Monad.Trans.Resource -import Data.Conduit +import Data.ByteString (ByteString) +import Data.Conduit hiding (await) +import Data.Monoid import Data.Time -import Network.AWS.Auth import Network.AWS.Data +import Network.AWS.Error +import Network.AWS.Internal.Auth import Network.AWS.Internal.Env import Network.AWS.Internal.Log +import Network.AWS.Internal.Retry import qualified Network.AWS.Signing as Sign import Network.AWS.Types -import Network.HTTP.Conduit hiding (Response) +import Network.AWS.Waiters +import qualified Network.HTTP.Conduit as Client +import Network.HTTP.Conduit hiding (Request, Response) -- | This creates a new environment without debug logging and uses 'getAuth' -- to expand/discover the supplied 'Credentials'. @@ -68,20 +90,21 @@ -> Credentials -> Manager -> ExceptT String m Env -newEnv r c m = Env r (\_ _ -> return ()) m `liftM` getAuth m c +newEnv r c m = Env r logger check Nothing m `liftM` getAuth m c + where + logger _ _ = return () + check _ _ = return True --- | Create a new environment without debug logging, creating a new 'Manager'. +-- | Create a new environment in the specified 'Region' with silent log output +-- and a new 'Manager'. -- -- Any errors are thrown using 'error'. -- --- /See:/ 'newEnv' +-- /See:/ 'newEnv' for safe 'Env' instantiation. getEnv :: Region -> Credentials -> IO Env getEnv r c = do m <- newManager conduitManagerSettings - e <- runExceptT (newEnv r c m) - either error - return - e + runExceptT (newEnv r c m) >>= either error return -- | Send a data type which is an instance of 'AWSRequest', returning either the -- associated 'Rs' response type in the success case, or the related service's @@ -89,27 +112,30 @@ -- -- This includes 'HTTPExceptions', serialisation errors, and any service -- errors returned as part of the 'Response'. +-- +-- /Note:/ Requests will be retried depending upon each service's respective +-- strategy. This can be overriden using 'envRetry'. Requests which contain +-- streaming request bodies (such as S3's 'PutObject') are never considered for retries. send :: (MonadCatch m, MonadResource m, AWSRequest a) => Env -> a -> m (Response a) -send Env{..} x@(request -> rq) = go `catch` er >>= response x - where - go = do - trace _envLogger (build rq) - - t <- liftIO getCurrentTime - - 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) +send e@Env{..} (request -> rq) = fmap snd <$> retrier e rq (raw e rq) - er ex = return (Left (ex :: HttpException)) +-- | Poll the API until a predefined condition is fulfilled using the +-- supplied 'Wait' specification from the respective service. +-- +-- The response will be either the first error returned that is not handled +-- by the specification, or the successful response from the await request. +-- +-- /Note:/ You can find any available 'Wait' specifications under then +-- @Network.AWS..Waiters@ namespace for supported services. +await :: (MonadCatch m, MonadResource m, AWSRequest a) + => Env + -> Wait a + -> a + -> m (Response a) +await e w (request -> rq) = fmap snd <$> waiter e w rq (raw e rq) -- | Send a data type which is an instance of 'AWSPager' and paginate over -- the associated 'Rs' response type in the success case, or the related service's @@ -123,14 +149,15 @@ -> Source m (Response a) paginate e = go where - go rq = do - rs <- lift (send e rq) - yield rs + go x = do + y <- lift (send e x) + yield y either (const (return ())) - (maybe (return ()) go . page rq) - rs + (maybe (return ()) go . page x) + y --- | Presign a URL with expiry to be used at a later time. +-- | Presign an HTTP request that expires at the specified amount of time +-- in the future. -- -- /Note:/ Requires the service's signer to be an instance of 'AWSPresigner'. -- Not all signing process support this. @@ -138,6 +165,50 @@ => Env -> a -- ^ Request to presign. -> UTCTime -- ^ Signing time. - -> UTCTime -- ^ Expiry time. - -> m (Signed a (Sg (Sv a))) -presign Env{..} (request -> rq) = Sign.presign _envAuth _envRegion rq + -> Integer -- ^ Expiry time in seconds. + -> m Client.Request +presign Env{..} (request -> rq) t ex = + _sgRequest `liftM` Sign.presign _envAuth _envRegion rq t ex + +-- | Presign a URL that expires at the specified amount of time in the future. +-- +-- /See:/ 'presign' +presignURL :: (MonadIO m, AWSRequest a, AWSPresigner (Sg (Sv a))) + => Env + -> a -- ^ Request to presign. + -> UTCTime -- ^ Signing time. + -> Integer -- ^ Expiry time in seconds. + -> m ByteString +presignURL e x t ex = (toBS . uri) `liftM` presign e x t ex + where + uri rq = + scheme (secure rq) + <> build (host rq) + <> port' (port rq) + <> build (path rq) + <> build (queryString rq) + + scheme True = "https://" + scheme _ = "http://" + + port' = \case + 80 -> "" + 443 -> "" + n -> build ':' <> build n + +raw :: (MonadCatch m, MonadResource m, AWSRequest a) + => Env + -> Request a + -> m (Response' a) +raw Env{..} rq = catch go err >>= response rq + where + go = do + trace _envLogger (build rq) + t <- liftIO getCurrentTime + Signed m s <- Sign.sign _envAuth _envRegion rq t + debug _envLogger (build s) + trace _envLogger (build m) + rs <- liftResourceT (http s _envManager) + return (Right rs) + + err ex = return (Left (ex :: HttpException)) diff --git a/src/Network/AWS/Auth.hs b/src/Network/AWS/Auth.hs deleted file mode 100644 --- a/src/Network/AWS/Auth.hs +++ /dev/null @@ -1,204 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ViewPatterns #-} - --- Module : Network.AWS.Auth --- 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) - --- | Explicitly specify your Amazon AWS security credentials, or retrieve them --- from the underlying OS. -module Network.AWS.Auth - ( - -- * Defaults - accessKey - , secretKey - - -- * Specifying credentials - , fromKeys - , fromSession - - -- * Retrieving credentials - , Credentials (..) - , getAuth - ) where - -import Control.Applicative -import Control.Concurrent -import Control.Monad.Except -import qualified Data.ByteString.Char8 as BS -import qualified Data.ByteString.Lazy.Char8 as LBS -import Data.IORef -import Data.Monoid -import Data.Text (Text) -import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text -import Data.Time -import Network.AWS.Data -import Network.AWS.EC2.Metadata -import Network.AWS.Types -import Network.HTTP.Conduit -import System.Environment -import System.Mem.Weak - --- | Default access key environment variable. -accessKey :: Text -- ^ 'AWS_ACCESS_KEY' -accessKey = "AWS_ACCESS_KEY" - --- | Default secret key environment variable. -secretKey :: Text -- ^ 'AWS_SECRET_KEY' -secretKey = "AWS_SECRET_KEY" - --- | Explicit access and secret keys. -fromKeys :: AccessKey -> SecretKey -> Auth -fromKeys a s = Auth (AuthEnv a s Nothing Nothing) - --- | A session containing the access key, secret key, and a security token. -fromSession :: AccessKey -> SecretKey -> SecurityToken -> Auth -fromSession a s t = Auth (AuthEnv a s (Just t) Nothing) - --- | Determines how authentication information is retrieved. -data Credentials - = FromKeys AccessKey SecretKey - -- ^ Explicit access and secret keys. - -- /Note:/ you can achieve the same result purely using 'fromKeys' without - -- having to use the impure 'getAuth'. - | FromSession AccessKey SecretKey SecurityToken - -- ^ A session containing the access key, secret key, and a security token. - -- /Note:/ you can achieve the same result purely using 'fromSession' - -- without having to use the impure 'getAuth'. - | FromProfile Text - -- ^ An IAM Profile name to lookup from the local EC2 instance-data. - | FromEnv Text Text - -- ^ Environment variables to lookup for the access and secret keys. - | Discover - -- ^ Attempt to read the default access and secret keys from the environment, - -- falling back to the first available IAM profile if they are not set. - -- - -- /Note:/ This attempts to resolve rather than directly - -- retrieving for IAM profile information to ensure - -- the dns lookup terminates promptly if not running on EC2. - deriving (Eq) - -instance ToBuilder Credentials where - build = \case - FromKeys a _ -> "FromKeys " <> build a <> " ****" - FromSession a _ _ -> "FromSession " <> build a <> " **** ****" - FromProfile n -> "FromProfile " <> build n - FromEnv a s -> "FromEnv " <> build a <> " " <> build s - Discover -> "Discover" - -instance Show Credentials where - show = LBS.unpack . buildBS - --- | Retrieve authentication information using the specified 'Credentials' style. -getAuth :: (Functor m, MonadIO m) - => Manager - -> Credentials - -> ExceptT String m Auth -getAuth m = \case - FromKeys a s -> return (fromKeys a s) - FromSession a s t -> return (fromSession a s t) - FromProfile n -> show `withExceptT` fromProfileName m n - FromEnv a s -> fromEnvVars a s - Discover -> fromEnv `catchError` const (iam `catchError` const err) - where - iam = show `withExceptT` fromProfile m - err = throwError "Unable to read environment variables or IAM profile." - --- | Retrieve access and secret keys from the default environment variables. --- --- /See:/ 'accessKey' and 'secretKey' -fromEnv :: (Functor m, MonadIO m) => ExceptT String m Auth -fromEnv = fromEnvVars accessKey secretKey - --- | Retrieve access and secret keys from specific environment variables. -fromEnvVars :: (Functor m, MonadIO m) => Text -> Text -> ExceptT String m Auth -fromEnvVars a s = fmap Auth $ AuthEnv - <$> (AccessKey <$> key a) - <*> (SecretKey <$> key s) - <*> pure Nothing - <*> pure Nothing - where - key (Text.unpack -> k) = ExceptT $ do - m <- liftIO (lookupEnv k) - return $ - maybe (Left $ "Unable to read ENV variable: " ++ k) - (Right . BS.pack) - m - --- | Retrieve the default IAM Profile from the local EC2 instance-data. --- --- This determined by Amazon as the first IAM profile found in the response from: --- @http://169.254.169.254/latest/meta-data/iam/security-credentials/@ -fromProfile :: MonadIO m => Manager -> ExceptT HttpException m Auth -fromProfile m = do - !ls <- BS.lines `liftM` metadata m (IAM $ SecurityCredentials Nothing) - case ls of - (x:_) -> fromProfileName m (Text.decodeUtf8 x) - _ -> throwError $ - HttpParserException "Unable to get default IAM Profile from EC2 metadata" - --- | Lookup a specific IAM Profile by name from the local EC2 instance-data. --- --- The resulting IONewRef wrapper + timer is designed so that multiple concurrent --- accesses of 'AuthEnv' from the 'AWS' environment are not required to calculate --- expiry and sequentially queue to update it. --- --- The forked timer ensures a singular owner and pre-emptive refresh of the --- temporary session credentials. --- --- A weak reference is used to ensure that the forked thread will eventually --- terminate when 'Auth' is no longer referenced. -fromProfileName :: MonadIO m - => Manager - -> Text - -> ExceptT HttpException m Auth -fromProfileName m name = auth >>= start - where - auth :: MonadIO m => ExceptT HttpException m AuthEnv - auth = do - !lbs <- LBS.fromStrict `liftM` metadata m - (IAM . SecurityCredentials $ Just name) - either (throwError . HttpParserException) - return - (eitherDecode' lbs) - - start !a = ExceptT . liftM Right . liftIO $ - case _authExpiry a of - Nothing -> return (Auth a) - Just x -> do - r <- newIORef a - p <- myThreadId - s <- timer r p x - return (Ref s r) - - timer r p x = forkIO $ do - s <- myThreadId - w <- mkWeakIORef r (killThread s) - loop w p x - - loop w p x = do - diff x <$> getCurrentTime >>= threadDelay - ea <- runExceptT auth - case ea of - Left e -> throwTo p e - Right !a -> do - mr <- deRefWeak w - case mr of - Nothing -> return () - Just r -> do - atomicWriteIORef r a - maybe (return ()) (loop w p) (_authExpiry a) - - diff x y = (* 1000000) $ - let n = truncate (diffUTCTime x y) - 60 - in if n > 0 then n else 1 diff --git a/src/Network/AWS/Internal/Auth.hs b/src/Network/AWS/Internal/Auth.hs new file mode 100644 --- /dev/null +++ b/src/Network/AWS/Internal/Auth.hs @@ -0,0 +1,191 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} + +-- Module : Network.AWS.Internal.Auth +-- 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) + +-- | Explicitly specify your Amazon AWS security credentials, or retrieve them +-- from the underlying OS. +module Network.AWS.Internal.Auth where + +import Control.Applicative +import Control.Concurrent +import Control.Monad.Except +import qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString.Lazy.Char8 as LBS +import Data.IORef +import Data.Monoid +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import Data.Time +import Network.AWS.Data +import Network.AWS.EC2.Metadata +import Network.AWS.Types +import Network.HTTP.Conduit +import System.Environment +import System.Mem.Weak + +-- | Default access key environment variable. +accessKey :: Text -- ^ 'AWS_ACCESS_KEY' +accessKey = "AWS_ACCESS_KEY" + +-- | Default secret key environment variable. +secretKey :: Text -- ^ 'AWS_SECRET_KEY' +secretKey = "AWS_SECRET_KEY" + +-- | Explicit access and secret keys. +fromKeys :: AccessKey -> SecretKey -> Auth +fromKeys a s = Auth (AuthEnv a s Nothing Nothing) + +-- | A session containing the access key, secret key, and a security token. +fromSession :: AccessKey -> SecretKey -> SecurityToken -> Auth +fromSession a s t = Auth (AuthEnv a s (Just t) Nothing) + +-- | Determines how authentication information is retrieved. +data Credentials + = FromKeys AccessKey SecretKey + -- ^ Explicit access and secret keys. + -- /Note:/ you can achieve the same result purely using 'fromKeys' without + -- having to use the impure 'getAuth'. + | FromSession AccessKey SecretKey SecurityToken + -- ^ A session containing the access key, secret key, and a security token. + -- /Note:/ you can achieve the same result purely using 'fromSession' + -- without having to use the impure 'getAuth'. + | FromProfile Text + -- ^ An IAM Profile name to lookup from the local EC2 instance-data. + | FromEnv Text Text + -- ^ Environment variables to lookup for the access and secret keys. + | Discover + -- ^ Attempt to read the default access and secret keys from the environment, + -- falling back to the first available IAM profile if they are not set. + -- + -- /Note:/ This attempts to resolve rather than directly + -- retrieving for IAM profile information to ensure + -- the dns lookup terminates promptly if not running on EC2. + deriving (Eq) + +instance ToBuilder Credentials where + build = \case + FromKeys a _ -> "FromKeys " <> build a <> " ****" + FromSession a _ _ -> "FromSession " <> build a <> " **** ****" + FromProfile n -> "FromProfile " <> build n + FromEnv a s -> "FromEnv " <> build a <> " " <> build s + Discover -> "Discover" + +instance Show Credentials where + show = LBS.unpack . buildBS + +-- | Retrieve authentication information using the specified 'Credentials' style. +getAuth :: (Functor m, MonadIO m) + => Manager + -> Credentials + -> ExceptT String m Auth +getAuth m = \case + FromKeys a s -> return (fromKeys a s) + FromSession a s t -> return (fromSession a s t) + FromProfile n -> show `withExceptT` fromProfileName m n + FromEnv a s -> fromEnvVars a s + Discover -> fromEnv `catchError` const (iam `catchError` const err) + where + iam = show `withExceptT` fromProfile m + err = throwError "Unable to read environment variables or IAM profile." + +-- | Retrieve access and secret keys from the default environment variables. +-- +-- /See:/ 'accessKey' and 'secretKey' +fromEnv :: (Functor m, MonadIO m) => ExceptT String m Auth +fromEnv = fromEnvVars accessKey secretKey + +-- | Retrieve access and secret keys from specific environment variables. +fromEnvVars :: (Functor m, MonadIO m) => Text -> Text -> ExceptT String m Auth +fromEnvVars a s = fmap Auth $ AuthEnv + <$> (AccessKey <$> key a) + <*> (SecretKey <$> key s) + <*> pure Nothing + <*> pure Nothing + where + key (Text.unpack -> k) = ExceptT $ do + m <- liftIO (lookupEnv k) + return $ + maybe (Left $ "Unable to read ENV variable: " ++ k) + (Right . BS.pack) + m + +-- | Retrieve the default IAM Profile from the local EC2 instance-data. +-- +-- This determined by Amazon as the first IAM profile found in the response from: +-- @http://169.254.169.254/latest/meta-data/iam/security-credentials/@ +fromProfile :: MonadIO m => Manager -> ExceptT HttpException m Auth +fromProfile m = do + !ls <- BS.lines `liftM` metadata m (IAM $ SecurityCredentials Nothing) + case ls of + (x:_) -> fromProfileName m (Text.decodeUtf8 x) + _ -> throwError $ + HttpParserException "Unable to get default IAM Profile from EC2 metadata" + +-- | Lookup a specific IAM Profile by name from the local EC2 instance-data. +-- +-- The resulting IONewRef wrapper + timer is designed so that multiple concurrent +-- accesses of 'AuthEnv' from the 'AWS' environment are not required to calculate +-- expiry and sequentially queue to update it. +-- +-- The forked timer ensures a singular owner and pre-emptive refresh of the +-- temporary session credentials. +-- +-- A weak reference is used to ensure that the forked thread will eventually +-- terminate when 'Auth' is no longer referenced. +fromProfileName :: MonadIO m + => Manager + -> Text + -> ExceptT HttpException m Auth +fromProfileName m name = auth >>= start + where + auth :: MonadIO m => ExceptT HttpException m AuthEnv + auth = do + !lbs <- LBS.fromStrict `liftM` metadata m + (IAM . SecurityCredentials $ Just name) + either (throwError . HttpParserException) + return + (eitherDecode' lbs) + + start !a = ExceptT . liftM Right . liftIO $ + case _authExpiry a of + Nothing -> return (Auth a) + Just x -> do + r <- newIORef a + p <- myThreadId + s <- timer r p x + return (Ref s r) + + timer r p x = forkIO $ do + s <- myThreadId + w <- mkWeakIORef r (killThread s) + loop w p x + + loop w p x = do + diff x <$> getCurrentTime >>= threadDelay + ea <- runExceptT auth + case ea of + Left e -> throwTo p e + Right !a -> do + mr <- deRefWeak w + case mr of + Nothing -> return () + Just r -> do + atomicWriteIORef r a + maybe (return ()) (loop w p) (_authExpiry a) + + diff x y = (* 1000000) $ + let n = truncate (diffUTCTime x y) - 60 + in if n > 0 then n else 1 diff --git a/src/Network/AWS/Internal/Env.hs b/src/Network/AWS/Internal/Env.hs --- a/src/Network/AWS/Internal/Env.hs +++ b/src/Network/AWS/Internal/Env.hs @@ -1,6 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} -- Module : Network.AWS.Internal.Env -- Copyright : (c) 2013-2014 Brendan Hay @@ -15,6 +15,7 @@ module Network.AWS.Internal.Env where import Control.Lens +import Control.Retry import Data.List (intersperse) import Data.Monoid import Network.AWS.Data (ToBuilder(..)) @@ -24,18 +25,51 @@ -- | The environment containing the parameters required to make AWS requests. data Env = Env - { _envRegion :: !Region - , _envLogger :: Logger - , _envManager :: Manager - , _envAuth :: Auth + { _envRegion :: !Region + , _envLogger :: Logger + , _envRetryCheck :: Int -> HttpException -> IO Bool + , _envRetryPolicy :: Maybe RetryPolicy + , _envManager :: Manager + , _envAuth :: Auth } -makeLenses ''Env +-- | The current region. +envRegion :: Lens' Env Region +envRegion = lens _envRegion (\s a -> s { _envRegion = a }) +{-# INLINE envRegion #-} +-- | The function used to output log messages. +envLogger :: Lens' Env Logger +envLogger = lens _envLogger (\s a -> s { _envLogger = a }) +{-# INLINE envLogger #-} + +-- | The function used to determine if an 'HttpException' should be retried. +envRetryCheck :: Lens' Env (Int -> HttpException -> IO Bool) +envRetryCheck = lens _envRetryCheck (\s a -> s { _envRetryCheck = a }) +{-# INLINE envRetryCheck #-} + +-- | The 'RetryPolicy' used to determine backoff/on and retry delay/growth. +envRetryPolicy :: Lens' Env (Maybe RetryPolicy) +envRetryPolicy = lens _envRetryPolicy (\s a -> s { _envRetryPolicy = a }) +{-# INLINE envRetryPolicy #-} + +-- | The 'Manager' used to create and manage open HTTP connections. +envManager :: Lens' Env Manager +envManager = lens _envManager (\s a -> s { _envManager = a }) +{-# INLINE envManager #-} + +-- | The credentials used to sign requests for authentication with AWS. +envAuth :: Lens' Env Auth +envAuth = lens _envAuth (\s a -> s { _envAuth = a }) +{-# INLINE envAuth #-} + instance ToBuilder Env where build Env{..} = mconcat $ intersperse "\n" [ "[Environment] {" - , " region = " <> build _envRegion - , " auth = " <> build _envAuth + , " region = " <> build _envRegion + , " auth = " <> build _envAuth + , " retry (n=0) = " <> maybe "Nothing" policy _envRetryPolicy , "}" ] + where + policy (RetryPolicy f) = "Just " <> build (f 0) diff --git a/src/Network/AWS/Internal/Log.hs b/src/Network/AWS/Internal/Log.hs --- a/src/Network/AWS/Internal/Log.hs +++ b/src/Network/AWS/Internal/Log.hs @@ -14,6 +14,7 @@ -- request, response, and signing life-cycles. module Network.AWS.Internal.Log where +import Control.Monad import Control.Monad.IO.Class import Data.ByteString.Builder import Data.Monoid @@ -36,9 +37,8 @@ hSetBinaryMode hd True hSetBuffering hd LineBuffering return $ \y b -> - if x >= y - then hPutBuilder hd (b <> "\n") - else return () + when (x >= y) $ + hPutBuilder hd (b <> "\n") info :: (MonadIO m, ToBuilder a) => Logger -> a -> m () info f = liftIO . f Info . build diff --git a/src/Network/AWS/Internal/Retry.hs b/src/Network/AWS/Internal/Retry.hs new file mode 100644 --- /dev/null +++ b/src/Network/AWS/Internal/Retry.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +-- Module : Network.AWS.Internal.Retry +-- 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) + +module Network.AWS.Internal.Retry + ( retrier + , waiter + ) where + +import Control.Monad +import Control.Monad.IO.Class +import Control.Retry +import Data.List (intersperse) +import Data.Monoid +import Network.AWS.Internal.Env +import Network.AWS.Internal.Log +import Network.AWS.Prelude +import Network.AWS.Types +import Network.AWS.Waiters + +retrier :: (MonadIO m, AWSService (Sv a)) + => Env + -> Request a + -> m (Response' a) + -> m (Response' a) +retrier Env{..} rq = retrying (fromMaybe policy _envRetryPolicy) check + where + policy = limitRetries _retryAttempts + <> RetryPolicy (const $ listToMaybe [0 | not stream]) + <> RetryPolicy delay + where + !stream = isStreaming (_rqBody rq) + + delay n + | n > 0 = Just $ truncate (grow * 1000000) + | otherwise = Nothing + where + grow = _retryBase * (fromIntegral _retryGrowth ^^ (n - 1)) + + check n = \case + Left (ServiceError _ s e) + | _retryCheck s e -> msg n >> return True + Left (HttpError e) -> do + p <- liftIO (_envRetryCheck n e) + when p (msg n) >> return p + _ -> return False + + msg n = debug _envLogger $ + "[Retrying] after " <> build (n + 1) <> " attempts." + + Exponential{..} = _svcRetry (serviceOf rq) + +waiter :: MonadIO m + => Env + -> Wait a + -> Request a + -> m (Response' a) + -> m (Response' a) +waiter Env{..} w@Wait{..} rq = retrying policy check + where + policy = limitRetries _waitAttempts <> constantDelay (_waitDelay * 1000000) + + check n rs = do + let a = fromMaybe AcceptRetry (accept w rq rs) + msg n a >> return (retry a) + + retry AcceptSuccess = False + retry AcceptFailure = False + retry AcceptRetry = True + + msg n a = debug _envLogger + . mconcat + . intersperse " " + $ [ "[Await " <> build _waitName <> "]" + , build a + , " after " + , build (n + 1) + , "attempts." + ]