amazonka 0.0.7 → 0.0.8
raw patch · 8 files changed
+590/−307 lines, 8 filesdep +retrydep ~amazonka-coredep ~time
Dependencies added: retry
Dependency ranges changed: amazonka-core, time
Files
- amazonka.cabal +7/−5
- src/Control/Monad/Trans/AWS.hs +138/−40
- src/Network/AWS.hs +118/−47
- src/Network/AWS/Auth.hs +0/−204
- src/Network/AWS/Internal/Auth.hs +191/−0
- src/Network/AWS/Internal/Env.hs +42/−8
- src/Network/AWS/Internal/Log.hs +3/−3
- src/Network/AWS/Internal/Retry.hs +91/−0
amazonka.cabal view
@@ -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
src/Control/Monad/Trans/AWS.hs view
@@ -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.<ServiceName>.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)
src/Network/AWS.hs view
@@ -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.<ServiceName>.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))
− src/Network/AWS/Auth.hs
@@ -1,204 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ViewPatterns #-}---- Module : Network.AWS.Auth--- Copyright : (c) 2013-2014 Brendan Hay <brendan.g.hay@gmail.com>--- 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 <brendan.g.hay@gmail.com>--- 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 <http://instance-data> rather than directly- -- retrieving <http://169.254.169.254> 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
+ src/Network/AWS/Internal/Auth.hs view
@@ -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 <brendan.g.hay@gmail.com>+-- 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 <brendan.g.hay@gmail.com>+-- 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 <http://instance-data> rather than directly+ -- retrieving <http://169.254.169.254> 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
src/Network/AWS/Internal/Env.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TemplateHaskell #-} -- Module : Network.AWS.Internal.Env -- Copyright : (c) 2013-2014 Brendan Hay <brendan.g.hay@gmail.com>@@ -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)
src/Network/AWS/Internal/Log.hs view
@@ -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
+ src/Network/AWS/Internal/Retry.hs view
@@ -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 <brendan.g.hay@gmail.com>+-- 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 <brendan.g.hay@gmail.com>+-- 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."+ ]