diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -6,8 +6,9 @@ ## Description -Client library containing request and response primitives to be used alongside -the types from all `amazonka-*` libraries. +Client library containing request and response logic to communicate +with Amazon Web Service compatible APIs. Intended to be used alongside +the types supplied by the various `amazonka-*` service libraries. ## Contribute diff --git a/amazonka.cabal b/amazonka.cabal --- a/amazonka.cabal +++ b/amazonka.cabal @@ -1,5 +1,5 @@ name: amazonka -version: 0.3.6 +version: 1.0.0 synopsis: Comprehensive Amazon Web Services SDK homepage: https://github.com/brendanhay/amazonka license: OtherLicense @@ -13,11 +13,28 @@ cabal-version: >= 1.10 description: - Client library containing request and response primitives to be used - alongside the types from all amazonka related service libraries. + This client library contains request and response logic to communicate + with Amazon Web Service compatible APIs using the types supplied by the + various @amazonka-*@ service libraries. See the + category on Hackage for supported services. . - /Warning:/ This is an experimental preview release which is still under - heavy development and not intended for public consumption, caveat emptor! + To get started, import the desired @amazonka-*@ library (such as + ) + and one of the following: + . + * "Control.Monad.Trans.AWS": The 'Control.Monad.Trans.AWS.AWST' transformer + and generalised operations. + . + * "Network.AWS": The 'Network.AWS.AWS' monad and 'Network.AWS.MonadAWS' type + class for automatically lifting operations when embedded as a layer in a transformer stack. + This is built upon "Control.Monad.Trans.AWS". + . + Both 'Control.Monad.Trans.AWS.AWST' (and 'Network.AWS.AWS') and the provided + functions are built upon the 'Control.Monad.Trans.Free' DSL defined in + "Network.AWS.Free". This allows writing a custom interpreter (say, for + mocking purposes) and defining your own AWS logic if desired. + . + GHC 7.8.4 and higher is officially supported. source-repository head type: git @@ -32,33 +49,54 @@ exposed-modules: Control.Monad.Trans.AWS , Network.AWS + , Network.AWS.Auth + , Network.AWS.Data , Network.AWS.EC2.Metadata + , Network.AWS.Env + , Network.AWS.Free + , Network.AWS.Presign other-modules: - Network.AWS.Internal.Auth - , Network.AWS.Internal.Body - , Network.AWS.Internal.Env - , Network.AWS.Internal.Log - , Network.AWS.Internal.Retry + Network.AWS.Internal.Body + , Network.AWS.Internal.HTTP + , Network.AWS.Internal.Logger build-depends: - amazonka-core == 0.3.6.* + amazonka-core == 1.0.0.* , base >= 4.7 && < 5 , bytestring >= 0.9 , conduit >= 1.1 - , conduit-extra == 1.1.* - , cryptohash == 0.11.* - , cryptohash-conduit >= 0.1.1 + , conduit-extra >= 1.1 + , directory >= 1.2 , exceptions >= 0.6 + , free >= 4.5 + , http-client >= 0.4.9 , http-conduit >= 2.1.4 + , ini >= 0.2 , lens >= 4.4 - , mmorph >= 1 && < 2 - , monad-control >= 1 && < 2 + , mmorph >= 1 + , monad-control >= 1 , mtl >= 2.1.3.1 , resourcet >= 1.1 , retry >= 0.5 , text >= 1.1 , time >= 1.2 , transformers >= 0.2 - , transformers-base >= 0.4.2 + , transformers-base >= 0.4 , transformers-compat >= 0.3 + +test-suite tests + type: exitcode-stdio-1.0 + default-language: Haskell2010 + hs-source-dirs: test + main-is: Main.hs + + ghc-options: -Wall -threaded + + other-modules: + + build-depends: + amazonka + , base + , tasty + , tasty-hunit 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 @@ -1,446 +1,436 @@ -{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} - --- This is required due to the MonadBaseControl instance. {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -fno-warn-duplicate-exports #-} + +-- | -- Module : Control.Monad.Trans.AWS --- Copyright : (c) 2013-2015 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/. +-- Copyright : (c) 2013-2015 Brendan Hay +-- License : Mozilla Public License, v. 2.0. -- Maintainer : Brendan Hay --- Stability : experimental +-- Stability : provisional -- Portability : non-portable (GHC extensions) - --- | A monad transformer built on top of functions from "Network.AWS" which --- encapsulates various common parameters, errors, and usage patterns. +-- +-- The 'AWST' transformer provides the environment required to perform AWS +-- operations and constructs a 'Command' AST using 'FreeT' which can then be +-- interpreted using 'runAWST'. The transformer is intended to be used directly +-- or embedded as a layer within a transformer stack. +-- +-- "Network.AWS" contains a 'IO' specialised version of 'AWST' with a typeclass +-- to assist in automatically lifting operations. module Control.Monad.Trans.AWS ( - -- * Requests - -- ** Synchronous - send - , send_ - , sendCatch - -- ** Paginated + -- * Running AWS Actions + AWST + , runAWST + , execAWST + + -- * Authentication and Environment + , newEnv + , Env + , HasEnv (..) + + -- ** Credential Discovery + , Credentials (..) + -- $discovery + + -- ** Supported Regions + , Region (..) + + -- * Sending Requests + -- $sending + + , send + + -- ** Pagination + -- $pagination + , paginate - , paginateCatch - -- ** Eventual consistency - , await - , awaitCatch - -- ** Pre-signing URLs - , presign - , presignURL - -- * Transformer - , AWS - , AWST - , MonadAWS + -- ** Waiters + -- $waiters - -- * Running - , runAWST + , await - -- * Regionalisation - , Region (..) - , within + -- ** Overriding Service Configuration + -- $service - -- * Retries + -- *** Scoped Actions + , within , once - - -- * Environment - , Env - -- ** Lenses - , envRegion - , envLogger - , envRetryCheck - , envRetryPolicy - , envManager - , envAuth - -- ** Creating the environment - , AWS.newEnv - , AWS.getEnv - -- ** Specifying credentials - , Credentials (..) - , fromKeys - , fromSession - , getAuth - , accessKey - , secretKey + , timeout - -- * Logging - , newLogger - , info - , debug - , trace + -- *** Per Request + , sendWith + , paginateWith + , awaitWith + , presignWith - -- * Errors - , Error - , hoistEither - , throwAWSError - , verify - , verifyWith + -- ** Streaming + -- $streaming - -- ** Streaming body helpers + -- *** Request Bodies + , ToBody (..) , sourceBody , sourceHandle , sourceFile , sourceFileIO - -- * Types - , ToBuilder (..) + -- *** Response Bodies + , sinkBody + + -- *** File Size and MD5/SHA256 + , getFileSize + , sinkMD5 + , sinkSHA256 + + -- * Presigning Requests + -- $presigning + + , presignURL + , presign + + -- * EC2 Instance Metadata + -- $metadata + + , isEC2 + , dynamic + , metadata + , userdata + + , EC2.Dynamic (..) + , EC2.Metadata (..) + + -- * Running Asynchronous Actions + -- $async + + -- * Handling Errors + -- $errors + + , AsError (..) + , AsAuthError (..) + + , trying + , catching + + -- * Logging + -- $logging + + , Logger + , LogLevel (..) + + -- ** Constructing a Logger + , newLogger + + -- * Re-exported Types + , RqBody + , RsBody , module Network.AWS.Types - , module Network.AWS.Error + , module Network.AWS.Waiter + , module Network.AWS.Pager + + -- * runResourceT + , runResourceT ) where import Control.Applicative -import Control.Arrow (first) -import Control.Lens +import Control.Exception.Lens import Control.Monad.Base import Control.Monad.Catch -import Control.Monad.Error (MonadError, throwError) +import Control.Monad.Error.Class (MonadError (..)) import Control.Monad.Morph import Control.Monad.Reader +import Control.Monad.State.Class import Control.Monad.Trans.Control -import Control.Monad.Trans.Except +import Control.Monad.Trans.Free +import qualified Control.Monad.Trans.Free.Church as Free import Control.Monad.Trans.Resource -import Control.Retry (limitRetries) -import Data.ByteString (ByteString) -import Data.Conduit hiding (await) -import Data.Time (UTCTime) -import qualified Network.AWS as AWS -import Network.AWS.Data (ToBuilder (..)) -import Network.AWS.Error -import Network.AWS.Internal.Auth +import Control.Monad.Writer.Class +import Data.IORef +import Network.AWS.Auth +import qualified Network.AWS.EC2.Metadata as EC2 +import Network.AWS.Env +import Network.AWS.Free import Network.AWS.Internal.Body -import Network.AWS.Internal.Env -import Network.AWS.Internal.Log hiding (debug, info, trace) -import qualified Network.AWS.Internal.Log as Log -import Network.AWS.Types -import Network.AWS.Waiters -import qualified Network.HTTP.Conduit as Client - --- | The top-level error type. -type Error = ServiceError String - --- | A convenient alias for 'AWST' 'IO'. -type AWS = AWST IO - --- | Provides an alias for shortening type signatures if preferred. --- --- /Note:/ requires the @ConstraintKinds@ extension. -type MonadAWS m = - ( MonadBaseControl IO m - , MonadCatch m - , MonadResource m - , MonadError Error m - , MonadReader Env m - ) +import Network.AWS.Internal.HTTP +import Network.AWS.Internal.Logger +import Network.AWS.Pager (AWSPager) +import Network.AWS.Prelude as AWS +import qualified Network.AWS.Presign as Sign +import Network.AWS.Types hiding (LogLevel (..)) +import Network.AWS.Waiter (Wait) --- | The transformer. This satisfies all of the constraints that the functions --- in this module require, such as providing 'MonadResource' instances, --- 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 --- 'sendCatch' and 'paginateCatch'. -newtype AWST m a = AWST - { unAWST :: ReaderT (Env, InternalState) (ExceptT Error m) a - } deriving +-- | The 'AWST' transformer. +newtype AWST m a = AWST { unAWST :: FreeT Command (ReaderT Env m) a } + deriving ( Functor , Applicative , Alternative , Monad - , MonadIO , MonadPlus - , MonadThrow - , MonadCatch - , MonadError Error + , MonadIO + , MonadFree Command + , MonadReader Env ) -instance Monad m => MonadReader Env (AWST m) where - ask = AWST (fst `liftM` ask) - {-# INLINE ask #-} - - local f = AWST . local (first f) . unAWST - {-# INLINE local #-} +instance MonadThrow m => MonadThrow (AWST m) where + throwM = lift . throwM -instance MonadTrans AWST where - lift = AWST . lift . lift - {-# INLINE lift #-} +instance MonadCatch m => MonadCatch (AWST m) where + catch (AWST m) f = AWST (m `catch` \e -> unAWST (f e)) instance MonadBase b m => MonadBase b (AWST m) where liftBase = liftBaseDefault - {-# INLINE liftBase #-} -instance MonadTransControl AWST where - type StT AWST a = - StT (ExceptT Error) (StT (ReaderT (Env, InternalState)) a) +instance MFunctor AWST where + hoist nat = AWST . hoistFreeT (hoist nat) . unAWST - liftWith f = AWST $ - liftWith $ \g -> - liftWith $ \h -> - f (h . g . unAWST) - {-# INLINE liftWith #-} +instance MonadBaseControl b m => MonadBaseControl b (AWST m) where + type StM (AWST m) a = + StM m (FreeF Command a (FreeT Command (ReaderT Env m) a)) - restoreT = AWST . restoreT . restoreT - {-# INLINE restoreT #-} + liftBaseWith f = AWST . FreeT . liftM Pure $ + liftBaseWith $ \runInBase -> + f $ \k -> + runInBase (runFreeT (unAWST k)) -instance MonadBaseControl b m => MonadBaseControl b (AWST m) where - type StM (AWST m) a = ComposeSt AWST m a + restoreM = AWST . FreeT . restoreM - liftBaseWith = defaultLiftBaseWith - {-# INLINE liftBaseWith #-} +instance MonadTrans AWST where + lift = AWST . lift . lift - restoreM = defaultRestoreM - {-# INLINE restoreM #-} +instance MonadResource m => MonadResource (AWST m) where + liftResourceT = lift . liftResourceT -instance MFunctor AWST where - hoist nat m = AWST (ReaderT (ExceptT . nat . runAWST' m)) - {-# INLINE hoist #-} +instance MonadError e m => MonadError e (AWST m) where + throwError = lift . throwError + catchError m f = AWST (unAWST m `catchError` (unAWST . f)) -instance MMonad AWST where - embed f m = liftM2 (,) ask resources - >>= f . runAWST' m - >>= either throwError return - {-# INLINE embed #-} +instance MonadState s m => MonadState s (AWST m) where + get = lift get + put = lift . put -instance (Applicative m, MonadIO m, MonadBase IO m, MonadThrow m) - => MonadResource (AWST m) where - liftResourceT f = resources >>= liftIO . runInternalState f - {-# INLINE liftResourceT #-} +instance MonadWriter w m => MonadWriter w (AWST m) where + writer = lift . writer + tell = lift . tell + listen = AWST . listen . unAWST + pass = AWST . pass . unAWST --- | Unwrap an 'AWST' transformer, calling all of the registered 'ResourceT' --- release actions. -runAWST :: MonadBaseControl IO m => Env -> AWST m a -> m (Either Error a) -runAWST e m = runResourceT . withInternalState $ runAWST' f . (e,) +-- | Run an 'AWST' action with the specified 'HasEnv' environment. +-- Any outstanding HTTP responses' 'ResumableSource' will +-- be closed when the 'ResourceT' computation is unwrapped with 'runResourceT'. +-- +-- Throws 'Error' during interpretation of the underlying 'FreeT' 'Command' AST. +-- +-- /See:/ 'runResourceT'. +runAWST :: (MonadCatch m, MonadResource m, HasEnv r) => r -> AWST m a -> m a +runAWST = execAWST hoistError + +-- | Run an 'AWST' action with configurable 'Error' handling. +-- +-- Does not explictly throw 'Error's and instead uses the supplied lift function. +execAWST :: (MonadCatch m, MonadResource m, HasEnv r) + => (forall a. Either Error a -> m a) + -- ^ Lift an 'Error' into the base Monad. + -> r + -> AWST m b + -> m b +execAWST f = innerAWST go where - f = liftBase (_envLogger e Debug (build e)) >> m + go (CheckF k) = do + io <- view envEC2 + mp <- liftIO (readIORef io) + case mp of + Just p -> k p + Nothing -> do + m <- view envManager + !r <- lift . f =<< tryT (EC2.isEC2 m) + liftIO (atomicWriteIORef io (Just r)) + k r -runAWST' :: AWST m a -> (Env, InternalState) -> m (Either Error a) -runAWST' (AWST k) = runExceptT . runReaderT k + go (DynF x k) = do + m <- view envManager + r <- lift . f =<< tryT (EC2.dynamic m x) + k r -resources :: Monad m => AWST m InternalState -resources = AWST (ReaderT (return . snd)) + go (MetaF x k) = do + m <- view envManager + r <- lift . f =<< tryT (EC2.metadata m x) + k r --- | Hoist an 'Either' throwing the 'Left' case, and returning the 'Right'. -hoistEither :: (MonadError Error m, AWSError e) => Either e a -> m a -hoistEither = either throwAWSError return + go (UserF k) = do + m <- view envManager + r <- lift . f =<< tryT (EC2.userdata m) + k r --- | Throw any 'AWSError' using 'throwError'. -throwAWSError :: (MonadError Error m, AWSError e) => e -> m a -throwAWSError = throwError . awsError + go (SignF s ts ex x k) = do + a <- view envAuth + g <- view envRegion + r <- Sign.presignWith (const s) a g ts ex x + k r --- | Verify that an 'AWSError' matches the given 'Prism', otherwise throw the --- error using 'throwAWSError'. -verify :: (AWSError e, MonadError Error m) - => Prism' e a - -> e - -> m () -verify p e - | isn't p e = throwAWSError e - | otherwise = return () + go (SendF s (request -> x) k) = do + e <- view environment + r <- lift . f =<< retrier e s x (perform e s x) + k (snd r) --- | 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) - -> e - -> m () -verifyWith p f e = either (const err) g (matching p e) - where - g x | f x = return () - | otherwise = err + go (AwaitF s w (request -> x) k) = do + e <- view environment + r <- lift . f =<< waiter e w x (perform e s x) + k (snd r) - err = throwAWSError e + tryT m = either (Left . TransportError) Right <$> try m --- | Pass the current environment to a function. -scoped :: MonadReader Env m => (Env -> m a) -> m a -scoped f = ask >>= f +innerAWST :: (Monad m, HasEnv r) + => (Command (ReaderT Env m a) -> ReaderT Env m a) + -> r + -> AWST m a + -> m a +innerAWST f e (AWST m) = + runReaderT (f `Free.iterT` Free.toFT m) (e ^. environment) --- | Use the supplied logger from 'envLogger' to log info messages. --- --- /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) +hoistError :: MonadThrow m => Either Error a -> m a +hoistError = either (throwingM _Error) return --- | Use the supplied logger from 'envLogger' to log debug messages. -debug :: (MonadIO m, MonadReader Env m, ToBuilder a) => a -> m () -debug x = view envLogger >>= (`Log.debug` x) +{- $discovery +AuthN/AuthZ information is handled similarly to other AWS SDKs. You can read +some of the options available . --- | Use the supplied logger from 'envLogger' to log trace messages. -trace :: (MonadIO m, MonadReader Env m, ToBuilder a) => a -> m () -trace x = view envLogger >>= (`Log.trace` x) +When running on an EC2 instance and using 'FromProfile' or 'Discover', a thread +is forked which transparently handles the expiry and subsequent refresh of IAM +profile information. See 'Network.AWS.Auth.fromProfileName' for more information. +-} --- | Scope a monadic action within the specific 'Region'. -within :: MonadReader Env m => Region -> m a -> m a -within r = local (envRegion .~ r) +{- $sending +To send a request you need to create a value of the desired operation type using +the relevant constructor, as well as any further modifications of default/optional +parameters using the appropriate lenses. This value can then be sent using 'send' +or 'paginate' and the library will take care of serialisation/authentication and +so forth. --- | 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 $ \e -> - e & envRetryPolicy ?~ limitRetries 0 - & envRetryCheck .~ (\_ _ -> return False) +The default 'Service' configuration for a request (or the supplied 'Service' configuration +when using the @*With@ variants) contains retry configuration that is used to +determine if a request can safely be retried and what kind of back off/on strategy +should be used. (Usually exponential.) +Typically services define retry strategies that handle throttling, general server +errors and transport errors. Streaming requests are never retried. +-} --- | Send a data type which is an instance of 'AWSRequest', returning it's --- associated 'Rs' response type. --- --- This will throw any 'HTTPException' or 'AWSServiceError' returned by the --- 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 - , MonadError Error m - , AWSRequest a - ) - => a - -> m (Rs a) -send = sendCatch >=> hoistEither +{- $pagination +Some AWS operations return results that are incomplete and require subsequent +requests in order to obtain the entire result set. The process of sending +subsequent requests to continue where a previous request left off is called +pagination. For example, the 'ListObjects' operation of Amazon S3 returns up to +1000 objects at a time, and you must send subsequent requests with the +appropriate Marker in order to retrieve the next page of results. --- | A variant of 'send' which discards any successful response. --- --- /See:/ 'send' -send_ :: ( MonadCatch m - , MonadResource m - , MonadReader Env m - , MonadError Error m - , AWSRequest a - ) - => a - -> m () -send_ = void . send +Operations that have an 'AWSPager' instance can transparently perform subsequent +requests, correctly setting Markers and other request facets to iterate through +the entire result set of a truncated API operation. Operations which support +this have an additional note in the documentation. --- | 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 --- 'Er' type in the error case. --- --- 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 - , AWSRequest a - ) - => a - -> m (Response a) -sendCatch x = scoped (`AWS.send` x) +Many operations have the ability to filter results on the server side. See the +individual operation parameters for details. +-} --- | Send a data type which is an instance of 'AWSPager' and paginate while --- there are more results as defined by the related service operation. --- --- Errors will be handle identically to 'send'. --- --- /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 - , MonadError Error m - , AWSPager a - ) - => a - -> Source m (Rs a) -paginate x = paginateCatch x $= awaitForever (hoistEither >=> yield) +{- $waiters +Waiters poll by repeatedly sending a request until some remote success condition +configured by the 'Wait' specification is fulfilled. The 'Wait' specification +determines how many attempts should be made, in addition to delay and retry strategies. +Error conditions that are not handled by the 'Wait' configuration will be thrown, +or the first successful response that fulfills the success condition will be +returned. --- | 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 --- 'Er' type in the error case. --- --- /Note:/ The 'ResumableSource' will close when there are no more results or the --- 'ResourceT' computation is unwrapped. See: 'runResourceT' for more information. -paginateCatch :: ( MonadCatch m - , MonadResource m - , MonadReader Env m - , AWSPager a - ) - => a - -> Source m (Response a) -paginateCatch x = scoped (`AWS.paginate` x) +'Wait' specifications can be found under the @Network.AWS.{ServiceName}.Waiters@ +namespace for services which support 'await'. +-} --- | 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 +{- $service +When a request is sent, various configuration values such as the endpoint, +retry strategy, timeout and error handlers are taken from the associated 'Service' +configuration. --- | 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) +You can override the default configuration for a series of one or more actions +by using 'within', 'once' and 'timeout', or by using the @*With@ suffixed +functions on an individual request basis below. +-} --- | 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 - , MonadReader Env m - , AWSRequest a - , AWSPresigner (Sg (Sv a)) - ) - => a -- ^ Request to presign. - -> UTCTime -- ^ Signing time. - -> Integer -- ^ Expiry time in seconds. - -> m Client.Request -presign x t ex = scoped (\e -> AWS.presign e x t ex) +{- $streaming +Streaming request bodies (such as 'PutObject') require a precomputed +'SHA256' for signing purposes. +The 'ToBody' typeclass has instances available to construct a 'RqBody', +automatically calculating the hash as needed for types such as 'Text' and 'ByteString'. --- | 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) +For reading files and handles, functions such 'sourceFileIO' or 'sourceHandle' +can be used. +For responses that contain streaming bodies (such as 'GetObject'), you can use +'sinkBody' to connect the response body to a +compatible sink. +-} + +{- $presigning +Presigning requires the 'Service' signer to be an instance of 'AWSPresigner'. +Not all signing algorithms support this. +-} + +{- $metadata +Metadata can be retrieved from the underlying host assuming that you're running +the code on an EC2 instance or have a compatible @instance-data@ endpoint available. +-} + +{- $async +Requests can be sent asynchronously, but due to guarantees about resource closure +require the use of . + +The following example demonstrates retrieving two objects from S3 concurrently: + +> import Control.Concurrent.Async.Lifted +> import Control.Lens +> import Control.Monad.Trans.AWS +> import Network.AWS.S3 +> +> do x <- async . send $ getObject "bucket" "prefix/object-foo" +> y <- async . send $ getObject "bucket" "prefix/object-bar" +> foo <- wait x +> bar <- wait y +> ... + +/See:/ +-} + +{- $errors +Errors are thrown by the library using 'MonadThrow' (unless "Control.Monad.Error.AWS" is used). +Sub-errors of the canonical 'Error' type can be caught using 'trying' or +'catching' and the appropriate 'AsError' 'Prism': + +@ +trying '_Error' (send $ ListObjects "bucket-name") :: Either 'Error' ListObjectsResponse +trying '_TransportError' (send $ ListObjects "bucket-name") :: Either 'HttpException' ListObjectsResponse +trying '_SerializeError' (send $ ListObjects "bucket-name") :: Either 'SerializeError' ListObjectsResponse +trying '_ServiceError' (send $ ListObjects "bucket-name") :: Either 'ServiceError' ListObjectsResponse +@ + +Many of the individual @amazonka-*@ libraries export compatible 'Getter's for +matching service specific error codes and messages in the style above. +See the @Error Matchers@ heading in each respective library for details. +-} + +{- $logging +The exposed logging interface is a primitive 'Logger' function which gets +threaded through service calls and serialisation routines. This allows the +library to output useful information and diagnostics. + +The 'newLogger' function can be used to construct a simple logger which writes +output to a 'Handle', but in most production code you should probably consider +using a more robust logging library such as + or +. +-} diff --git a/src/Network/AWS.hs b/src/Network/AWS.hs --- a/src/Network/AWS.hs +++ b/src/Network/AWS.hs @@ -1,223 +1,459 @@ -{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE FlexibleInstances #-} +{-# OPTIONS_GHC -fno-warn-duplicate-exports #-} + +-- | -- Module : Network.AWS --- Copyright : (c) 2013-2015 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/. +-- Copyright : (c) 2013-2015 Brendan Hay +-- License : Mozilla Public License, v. 2.0. -- Maintainer : Brendan Hay --- Stability : experimental +-- Stability : provisional -- Portability : non-portable (GHC extensions) - --- | The core module for making requests to the various AWS services. +-- +-- This module provides a simple 'AWS' monad and a set of operations which +-- can be performed against remote Amazon Web Services APIs, for use with the types +-- supplied by the various @amazonka-*@ libraries. +-- +-- A 'MonadAWS' typeclass is used as a function constraint to provide automatic +-- lifting of functions when embedding 'AWS' as a layer inside your own +-- application stack. +-- +-- "Control.Monad.Trans.AWS" contains the underlying 'AWST' transformer. module Network.AWS ( - -- * Requests - -- ** Synchronous - send - -- ** Paginated + -- * Usage + -- $usage + + -- * Running AWS Actions + AWS + , MonadAWS (..) + , runAWS + + -- * Authentication and Environment + , newEnv + , Env + , HasEnv (..) + + -- ** Credential Discovery + , Credentials (..) + -- $discovery + + -- ** Supported Regions + , Region (..) + + -- * Sending Requests + -- $sending + + , send + + -- ** Pagination + -- $pagination + , paginate - -- ** Eventual consistency + + -- ** Waiters + -- $waiters + , await - -- ** Pre-signing URLs - , presign - , presignURL - -- * Environment - , Env - -- ** Lenses - , envRegion - , envLogger - , envRetryCheck - , envRetryPolicy - , envManager - , envAuth - -- ** Creating the environment - , newEnv - , getEnv - -- ** Specifying credentials - , Credentials (..) - , fromKeys - , fromSession - , getAuth - , accessKey - , secretKey + -- ** Overriding Service Configuration + -- $service - -- * Logging - , newLogger + -- *** Scoped Actions + , within + , once + , timeout - -- ** Streaming body helpers + -- ** Streaming + -- $streaming + + -- *** Request Bodies + , ToBody (..) , sourceBody , sourceHandle , sourceFile , sourceFileIO - -- * Types + -- *** Response Bodies + , sinkBody + + -- *** File Size and MD5/SHA256 + , getFileSize + , sinkMD5 + , sinkSHA256 + + -- * Presigning Requests + -- $presigning + + , presignURL + + -- * EC2 Instance Metadata + -- $metadata + + , isEC2 + , dynamic + , metadata + , userdata + + , EC2.Dynamic (..) + , EC2.Metadata (..) + + -- * Running Asynchronous Actions + -- $async + + -- * Handling Errors + -- $errors + + , AsError (..) + , AsAuthError (..) + + , AWST.trying + , AWST.catching + + -- * Logging + -- $logging + + , Logger + , LogLevel (..) + + -- ** Constructing a Logger + , newLogger + + -- * Re-exported Types + , RqBody + , RsBody , module Network.AWS.Types - , module Network.AWS.Error + , module Network.AWS.Waiter + , module Network.AWS.Pager + + -- * runResourceT + , runResourceT ) where import Control.Applicative -import Control.Monad -import Control.Monad.Catch -import Control.Monad.IO.Class -import Control.Monad.Trans.Class -import Control.Monad.Trans.Except +import Control.Monad.Catch (MonadCatch) +import Control.Monad.Morph (hoist) +import qualified Control.Monad.RWS.Lazy as LRW +import qualified Control.Monad.RWS.Strict as RW +import qualified Control.Monad.State.Lazy as LS +import qualified Control.Monad.State.Strict as S +import Control.Monad.Trans.AWS (AWST) +import qualified Control.Monad.Trans.AWS as AWST +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Cont (ContT) +import Control.Monad.Trans.Except (ExceptT) +import Control.Monad.Trans.Free (FreeT) +import Control.Monad.Trans.Free.Church (FT) +import Control.Monad.Trans.Identity (IdentityT) +import Control.Monad.Trans.Iter (IterT) +import Control.Monad.Trans.List (ListT) +import Control.Monad.Trans.Maybe (MaybeT) +import Control.Monad.Trans.Reader (ReaderT) import Control.Monad.Trans.Resource -import Data.ByteString (ByteString) -import Data.Conduit hiding (await) +import qualified Control.Monad.Writer.Lazy as LW +import qualified Control.Monad.Writer.Strict as W +import Data.Conduit (Source) import Data.Monoid -import Data.Time (getCurrentTime) -import Network.AWS.Data -import Network.AWS.Error -import Network.AWS.Internal.Auth +import Network.AWS.Auth +import qualified Network.AWS.EC2.Metadata as EC2 +import Network.AWS.Env (Env, HasEnv (..), newEnv) import Network.AWS.Internal.Body -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.AWS.Waiters -import Network.HTTP.Conduit hiding (Request, Response) -import qualified Network.HTTP.Conduit as Client +import Network.AWS.Internal.Logger +import Network.AWS.Pager (AWSPager) +import Network.AWS.Prelude +import Network.AWS.Types hiding (LogLevel (..)) +import Network.AWS.Waiter (Wait) --- | This creates a new environment without debug logging and uses 'getAuth' --- to expand/discover the supplied 'Credentials'. --- --- Lenses such as 'envLogger' can be used to modify the 'Env' with a debug logger. -newEnv :: (Functor m, MonadIO m) - => Region - -> Credentials - -> Manager - -> ExceptT String m Env -newEnv r c m = Env r logger check Nothing m `liftM` getAuth m c - where - logger _ _ = return () - check _ _ = return True +import Prelude --- | Create a new environment in the specified 'Region' with silent log output --- and a new 'Manager'. --- --- Any errors are thrown using 'error'. --- --- /See:/ 'newEnv' for safe 'Env' instantiation. -getEnv :: Region -> Credentials -> IO Env -getEnv r c = do - m <- newManager conduitManagerSettings - runExceptT (newEnv r c m) >>= either error return +-- | A specialisation of the 'AWST' transformer. +type AWS = AWST IO --- | 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 --- 'Er' type in the error case. +-- | Monads in which 'AWS' actions may be embedded. +class (Functor m, Applicative m, Monad m) => MonadAWS m where + -- | Lift a computation to the 'AWS' monad. + liftAWS :: AWS a -> m a + +instance MonadAWS AWS where + liftAWS = id + +instance MonadAWS m => MonadAWS (IdentityT m) where liftAWS = lift . liftAWS +instance MonadAWS m => MonadAWS (ListT m) where liftAWS = lift . liftAWS +instance MonadAWS m => MonadAWS (MaybeT m) where liftAWS = lift . liftAWS +instance MonadAWS m => MonadAWS (ExceptT e m) where liftAWS = lift . liftAWS +instance MonadAWS m => MonadAWS (ContT r m) where liftAWS = lift . liftAWS +instance MonadAWS m => MonadAWS (ReaderT r m) where liftAWS = lift . liftAWS +instance MonadAWS m => MonadAWS (S.StateT s m) where liftAWS = lift . liftAWS +instance MonadAWS m => MonadAWS (LS.StateT s m) where liftAWS = lift . liftAWS +instance MonadAWS m => MonadAWS (IterT m) where liftAWS = lift . liftAWS +instance MonadAWS m => MonadAWS (FT f m) where liftAWS = lift . liftAWS + +instance (Monoid w, MonadAWS m) => MonadAWS (W.WriterT w m) where + liftAWS = lift . liftAWS + +instance (Monoid w, MonadAWS m) => MonadAWS (LW.WriterT w m) where + liftAWS = lift . liftAWS + +instance (Monoid w, MonadAWS m) => MonadAWS (RW.RWST r w s m) where + liftAWS = lift . liftAWS + +instance (Monoid w, MonadAWS m) => MonadAWS (LRW.RWST r w s m) where + liftAWS = lift . liftAWS + +instance (Functor f, MonadAWS m) => MonadAWS (FreeT f m) where + liftAWS = lift . liftAWS + +-- FIXME: verify the use of withInternalState to create a ResourceT here + +-- | Run the 'AWS' monad. Any outstanding HTTP responses' 'ResumableSource' will +-- be closed when the 'ResourceT' computation is unwrapped with 'runResourceT'. -- --- This includes 'HTTPExceptions', serialisation errors, and any service --- errors returned as part of the 'Response'. +-- Throws 'Error', which will include 'HTTPExceptions', serialisation errors, +-- or any particular errors returned by the respective AWS service. -- --- /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 e@Env{..} (request -> rq) = fmap snd <$> retrier e rq (raw e rq) +-- /See:/ 'runAWST', 'runResourceT'. +runAWS :: (MonadCatch m, MonadResource m, HasEnv r) => r -> AWS a -> m a +runAWS e = liftResourceT . AWST.runAWST e . hoist (withInternalState . const) --- | 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. +-- | Scope an action within the specific 'Region'. +within :: MonadAWS m => Region -> AWS a -> m a +within r = liftAWS . AWST.within r + +-- | Scope an action such that any retry logic for the 'Service' is +-- ignored and any requests will at most be sent once. +once :: MonadAWS m => AWS a -> m a +once = liftAWS . AWST.once + +-- | Scope an action such that any HTTP response will use this timeout value. +timeout :: MonadAWS m => Seconds -> AWS a -> m a +timeout s = liftAWS . AWST.timeout s + +-- | Send a request, returning the associated response if successful. -- --- /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) +-- /See:/ 'AWST.sendWith' +send :: (MonadAWS m, AWSRequest a) => a -> m (Rs a) +send = liftAWS . AWST.send --- | 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 --- 'Er' type in the error case. +-- | Repeatedly send a request, automatically setting markers and +-- paginating over multiple responses while available. -- --- /Note:/ The 'ResumableSource' will close when there are no more results or the --- 'ResourceT' computation is unwrapped. See: 'runResourceT' for more information. -paginate :: (MonadCatch m, MonadResource m, AWSPager a) - => Env - -> a - -> Source m (Response a) -paginate e = go - where - go x = do - y <- lift (send e x) - yield y - either (const (return ())) - (maybe (return ()) go . page x) - y +-- /See:/ 'AWST.paginateWith' +paginate :: (MonadAWS m, AWSPager a) => a -> Source m (Rs a) +paginate = hoist liftAWS . AWST.paginate --- | Presign an HTTP request that expires at the specified amount of time --- in the future. +-- | Poll the API with the supplied request until a specific 'Wait' condition +-- is fulfilled. -- --- /Note:/ Requires the service's signer to be an instance of 'AWSPresigner'. --- Not all signing process support this. -presign :: (MonadIO m, AWSRequest a, AWSPresigner (Sg (Sv a))) - => Env - -> a -- ^ Request to presign. - -> UTCTime -- ^ Signing time. - -> Integer -- ^ Expiry time in seconds. - -> m Client.Request -presign Env{..} (request -> rq) t ex = - _sgRequest `liftM` Sign.presign _envAuth _envRegion rq t ex +-- /See:/ 'AWST.awaitWith' +await :: (MonadAWS m, AWSRequest a) => Wait a -> a -> m (Rs a) +await w = liftAWS . AWST.await w --- | Presign a URL that expires at the specified amount of time in the future. +-- | Presign an URL that is valid from the specified time until the +-- number of seconds expiry has elapsed. -- --- /See:/ 'presign' -presignURL :: (MonadIO m, AWSRequest a, AWSPresigner (Sg (Sv a))) - => Env - -> a -- ^ Request to presign. - -> UTCTime -- ^ Signing time. - -> Integer -- ^ Expiry time in seconds. +-- /See:/ 'AWST.presign', 'AWST.presignWith' +presignURL :: (MonadAWS m, AWSPresigner (Sg (Sv a)), AWSRequest a) + => UTCTime -- ^ Signing time. + -> Seconds -- ^ Expiry time. + -> a -- ^ Request to presign. -> 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) +presignURL t ex = liftAWS . AWST.presignURL t ex - scheme True = "https://" - scheme _ = "http://" +-- | Test whether the underlying host is running on EC2. +-- This is memoised and an HTTP request is made to the host's metadata +-- endpoint for the first call only. +isEC2 :: MonadAWS m => m Bool +isEC2 = liftAWS AWST.isEC2 - port' = \case - 80 -> "" - 443 -> "" - n -> build ':' <> build n +-- | Retrieve the specified 'Dynamic' data. +dynamic :: MonadAWS m => EC2.Dynamic -> m ByteString +dynamic = liftAWS . AWST.dynamic -raw :: (MonadCatch m, MonadResource m, AWSRequest a) - => Env - -> Request a - -> m (Response' a) -raw Env{..} rq = catch go err >>= response _envLogger 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) - debug _envLogger (build rs) - return (Right rs) +-- | Retrieve the specified 'Metadata'. +metadata :: MonadAWS m => EC2.Metadata -> m ByteString +metadata = liftAWS . AWST.metadata - err ex = return (Left (ex :: HttpException)) +-- | Retrieve the user data. Returns 'Nothing' if no user data is assigned +-- to the instance. +userdata :: MonadAWS m => m (Maybe ByteString) +userdata = liftAWS AWST.userdata + +{- $usage +The key functions dealing with the request/response lifecycle are: + +* 'send' + +* 'paginate' + +* 'await' + +To utilise these, you will need to specify what 'Region' you wish to operate in +and your Amazon credentials for AuthN/AuthZ purposes. + +'Credentials' can be supplied in a number of ways. Either via explicit keys, +via session profiles, or have Amazonka determine the credentials from an +underlying IAM Role/Profile. + +As a basic example, you might wish to store an object in an S3 bucket using +: + +@ +import Control.Lens +import Network.AWS +import Network.AWS.S3 +import System.IO + +example :: IO PutObjectResponse +example = do + -- To specify configuration preferences, 'newEnv' is used to create a new 'Env'. The 'Region' denotes the AWS region requests will be performed against, + -- and 'Credentials' is used to specify the desired mechanism for supplying or retrieving AuthN/AuthZ information. + -- In this case, 'Discover' will cause the library to try a number of options such as default environment variables, or an instance's IAM Profile: + e <- newEnv Frankfurt Discover + + -- A new 'Logger' to replace the default noop logger is created, with the logger set to print debug information and errors to stdout: + l <- newLogger Debug stdout + + -- The payload (and hash) for the S3 object is retrieved from a FilePath: + b <- sourceFileIO "local\/path\/to\/object-payload" + + -- We now run the AWS computation with the overriden logger, performing the PutObject request: + runAWS (e & envLogger .~ l) $ + send (putObject "bucket-name" "object-key" b) +@ +-} + +{- $discovery +AuthN/AuthZ information is handled similarly to other AWS SDKs. You can read +some of the options available . + +When running on an EC2 instance and using 'FromProfile' or 'Discover', a thread +is forked which transparently handles the expiry and subsequent refresh of IAM +profile information. See 'Network.AWS.Auth.fromProfileName' for more information. +-} + +{- $sending +To send a request you need to create a value of the desired operation type using +the relevant constructor, as well as any further modifications of default/optional +parameters using the appropriate lenses. This value can then be sent using 'send' +or 'paginate' and the library will take care of serialisation/authentication and +so forth. + +The default 'Service' configuration for a request (or the supplied 'Service' configuration +when using the @*With@ variants) contains retry configuration that is used to +determine if a request can safely be retried and what kind of back off/on strategy +should be used. (Usually exponential.) +Typically services define retry strategies that handle throttling, general server +errors and transport errors. Streaming requests are never retried. +-} + +{- $pagination +Some AWS operations return results that are incomplete and require subsequent +requests in order to obtain the entire result set. The process of sending +subsequent requests to continue where a previous request left off is called +pagination. For example, the 'ListObjects' operation of Amazon S3 returns up to +1000 objects at a time, and you must send subsequent requests with the +appropriate Marker in order to retrieve the next page of results. + +Operations that have an 'AWSPager' instance can transparently perform subsequent +requests, correctly setting Markers and other request facets to iterate through +the entire result set of a truncated API operation. Operations which support +this have an additional note in the documentation. + +Many operations have the ability to filter results on the server side. See the +individual operation parameters for details. +-} + +{- $waiters +Waiters poll by repeatedly sending a request until some remote success condition +configured by the 'Wait' specification is fulfilled. The 'Wait' specification +determines how many attempts should be made, in addition to delay and retry strategies. +Error conditions that are not handled by the 'Wait' configuration will be thrown, +or the first successful response that fulfills the success condition will be +returned. + +'Wait' specifications can be found under the @Network.AWS.{ServiceName}.Waiters@ +namespace for services which support 'await'. +-} + +{- $service +When a request is sent, various configuration values such as the endpoint, +retry strategy, timeout and error handlers are taken from the associated 'Service' +configuration. + +You can override the default configuration for a series of one or more actions +by using 'within', 'once' and 'timeout', or by using the @*With@ suffixed +functions on an individual request basis below. +-} + +{- $streaming +Streaming request bodies (such as 'PutObject') require a precomputed +'SHA256' for signing purposes. +The 'ToBody' typeclass has instances available to construct a 'RqBody', +automatically calculating the hash as needed for types such as 'Text' and 'ByteString'. + +For reading files and handles, functions such 'sourceFileIO' or 'sourceHandle' +can be used. +For responses that contain streaming bodies (such as 'GetObject'), you can use +'sinkBody' to connect the response body to a +compatible sink. +-} + +{- $presigning +Presigning requires the 'Service' signer to be an instance of 'AWSPresigner'. +Not all signing algorithms support this. +-} + +{- $metadata +Metadata can be retrieved from the underlying host assuming that you're running +the code on an EC2 instance or have a compatible @instance-data@ endpoint available. +-} + +{- $async +Requests can be sent asynchronously, but due to guarantees about resource closure +require the use of . + +The following example demonstrates retrieving two objects from S3 concurrently: + +> import Control.Concurrent.Async.Lifted +> import Control.Lens +> import Control.Monad.Trans.AWS +> import Network.AWS.S3 +> +> do x <- async . send $ getObject "bucket" "prefix/object-foo" +> y <- async . send $ getObject "bucket" "prefix/object-bar" +> foo <- wait x +> bar <- wait y +> ... + +/See:/ +-} + +{- $errors +Errors are thrown by the library using 'MonadThrow' (unless "Control.Monad.Error.AWS" is used). +Sub-errors of the canonical 'Error' type can be caught using 'trying' or +'catching' and the appropriate 'AsError' 'Prism': + +@ +trying '_Error' (send $ ListObjects "bucket-name") :: Either 'Error' ListObjectsResponse +trying '_TransportError' (send $ ListObjects "bucket-name") :: Either 'HttpException' ListObjectsResponse +trying '_SerializeError' (send $ ListObjects "bucket-name") :: Either 'SerializeError' ListObjectsResponse +trying '_ServiceError' (send $ ListObjects "bucket-name") :: Either 'ServiceError' ListObjectsResponse +@ + +Many of the individual @amazonka-*@ libraries export compatible 'Getter's for +matching service specific error codes and messages in the style above. +See the @Error Matchers@ heading in each respective library for details. +-} + +{- $logging +The exposed logging interface is a primitive 'Logger' function which gets +threaded through service calls and serialisation routines. This allows the +library to output useful information and diagnostics. + +The 'newLogger' function can be used to construct a simple logger which writes +output to a 'Handle', but in most production code you should probably consider +using a more robust logging library such as + or +. +-} diff --git a/src/Network/AWS/Auth.hs b/src/Network/AWS/Auth.hs new file mode 100644 --- /dev/null +++ b/src/Network/AWS/Auth.hs @@ -0,0 +1,446 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : Network.AWS.Auth +-- Copyright : (c) 2013-2015 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +-- +-- Explicitly specify your Amazon AWS security credentials, or retrieve them +-- from the underlying OS. +-- +-- The format of environment variables and the credentials file follows the official +-- . +module Network.AWS.Auth + ( + -- * Authentication + -- ** Retrieving authentication + getAuth + , Credentials (..) + , Auth + + -- ** Defaults + -- *** Environment + , envAccessKey + , envSecretKey + , envSessionToken + + -- *** Credentials File + , credAccessKey + , credSecretKey + , credSessionToken + , credProfile + , credFile + + -- $credentials + + , fromKeys + , fromSession + , fromEnv + , fromEnvKeys + , fromFile + , fromFilePath + , fromProfile + , fromProfileName + + -- ** Keys + , AccessKey (..) + , SecretKey (..) + , SessionToken (..) + + -- ** Handling Errors + , AsAuthError (..) + , AuthError (..) + ) where + +import Control.Applicative +import Control.Concurrent +import Control.Exception.Lens +import Control.Monad +import Control.Monad.Catch +import Control.Monad.IO.Class +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.ByteString.Lazy.Char8 as LBS8 +import qualified Data.Ini as INI +import Data.IORef +import Data.Monoid +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import Data.Time (diffUTCTime, getCurrentTime) +import Network.AWS.Data.Log +import Network.AWS.EC2.Metadata +import Network.AWS.Prelude +import Network.AWS.Types +import Network.HTTP.Conduit +import System.Directory (doesFileExist, getHomeDirectory) +import System.Environment +import System.Mem.Weak + +import Prelude + +-- | Default access key environment variable. +envAccessKey :: Text -- ^ AWS_ACCESS_KEY_ID +envAccessKey = "AWS_ACCESS_KEY_ID" + +-- | Default secret key environment variable. +envSecretKey :: Text -- ^ AWS_SECRET_ACCESS_KEY +envSecretKey = "AWS_SECRET_ACCESS_KEY" + +-- | Default session token environment variable. +envSessionToken :: Text -- ^ AWS_SESSION_TOKEN +envSessionToken = "AWS_SESSION_TOKEN" + +-- | Credentials INI file access key variable. +credAccessKey :: Text -- ^ aws_access_key_id +credAccessKey = "aws_access_key_id" + +-- | Credentials INI file secret key variable. +credSecretKey :: Text -- ^ aws_secret_access_key +credSecretKey = "aws_secret_access_key" + +-- | Credentials INI file session token variable. +credSessionToken :: Text -- ^ aws_session_token +credSessionToken = "aws_session_token" + +-- | Credentials INI default profile section variable. +credProfile :: Text -- ^ default +credProfile = "default" + +-- | Default path for the credentials file. This looks in in the @HOME@ directory +-- as determined by the +-- library. +-- +-- * UNIX/OSX: @$HOME/.aws/credentials@ +-- +-- * Windows: @C:\/Users\//\\.aws\credentials@ +-- +-- /Note:/ This does not match the default AWS SDK location of +-- @%USERPROFILE%\.aws\credentials@ on Windows. (Sorry.) +credFile :: MonadIO m => m FilePath +credFile = (<> "/.aws/credentials") `liftM` liftIO getHomeDirectory +-- TODO: probably should be using System.FilePath above. + +{- $credentials +'getAuth' is implemented using the following @from*@-styled functions below. +Both 'fromKeys' and 'fromSession' can be used directly to avoid the 'MonadIO' +constraint. +-} + +-- | 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 session token. +fromSession :: AccessKey -> SecretKey -> SessionToken -> Auth +fromSession a s t = Auth (AuthEnv a s (Just t) Nothing) + +-- | Determines how AuthN/AuthZ information is retrieved. +data Credentials + = FromKeys AccessKey SecretKey + -- ^ Explicit access and secret keys. See 'fromKeys'. + + | FromSession AccessKey SecretKey SessionToken + -- ^ Explicit access key, secret key and a session token. See 'fromSession'. + + | FromEnv Text Text (Maybe Text) + -- ^ Lookup specific environment variables for access key, secret key, and + -- an optional session token respectively. + + | FromProfile Text + -- ^ An IAM Profile name to lookup from the local EC2 instance-data. + -- ^ Environment variables to lookup for the access key, secret key and + -- optional session token. + + | FromFile Text FilePath + -- ^ A credentials profile name (the INI section) and the path to the AWS + -- file. + + | Discover + -- ^ Attempt to credentials discovery via the following steps: + -- + -- * Read the 'envAccessKey' and 'envSecretKey' from the environment if they are set. + -- + -- * Read the credentials file if 'credFile' exists. + -- + -- * Retrieve the first available IAM profile if running on EC2. + -- + -- An attempt is made to resolve rather than directly + -- retrieving for IAM profile information. + -- This assists in ensuring the DNS lookup terminates promptly if not + -- running on EC2. + deriving (Eq) + +instance ToLog Credentials where + build = \case + FromKeys a _ -> "FromKeys " <> build a <> " ****" + FromSession a _ _ -> "FromSession " <> build a <> " **** ****" + FromEnv a s t -> "FromEnv " <> build a <> " " <> build s <> " " <> m t + FromProfile n -> "FromProfile " <> build n + FromFile n f -> "FromFile " <> build n <> " " <> build f + Discover -> "Discover" + where + m (Just x) = "(Just " <> build x <> ")" + m Nothing = "Nothing" + +instance Show Credentials where + show = BS8.unpack . toBS . build + +-- | An error thrown when attempting to read AuthN/AuthZ information. +data AuthError + = RetrievalError HttpException + | MissingEnvError Text + | MissingFileError FilePath + | InvalidFileError Text + | InvalidIAMError Text + deriving (Show, Typeable) + +instance Exception AuthError + +instance ToLog AuthError where + build = \case + RetrievalError e -> build e + MissingEnvError e -> "[MissingEnvError] { message = " <> build e <> "}" + MissingFileError f -> "[MissingFileError] { path = " <> build f <> "}" + InvalidFileError e -> "[InvalidFileError] { message = " <> build e <> "}" + InvalidIAMError e -> "[InvalidIAMError] { message = " <> build e <> "}" + +class AsAuthError a where + -- | A general authentication error. + _AuthError :: Prism' a AuthError + {-# MINIMAL _AuthError #-} + + -- | An error occured while communicating over HTTP with + -- the local metadata endpoint. + _RetrievalError :: Prism' a HttpException + + -- | An error occured looking up a named environment variable. + _MissingEnvError :: Prism' a Text + + -- | The specified credentials file could not be found. + _MissingFileError :: Prism' a FilePath + + -- | An error occured parsing the credentials file. + _InvalidFileError :: Prism' a Text + + -- | The specified IAM profile could not be found or deserialised. + _InvalidIAMError :: Prism' a Text + + _RetrievalError = _AuthError . _RetrievalError + _MissingEnvError = _AuthError . _MissingEnvError + _MissingFileError = _AuthError . _MissingFileError + _InvalidFileError = _AuthError . _InvalidFileError + _InvalidIAMError = _AuthError . _InvalidIAMError + +instance AsAuthError SomeException where + _AuthError = exception + +instance AsAuthError AuthError where + _AuthError = id + + _RetrievalError = prism RetrievalError $ \case + RetrievalError e -> Right e + x -> Left x + + _MissingEnvError = prism MissingEnvError $ \case + MissingEnvError e -> Right e + x -> Left x + + _MissingFileError = prism MissingFileError $ \case + MissingFileError f -> Right f + x -> Left x + + _InvalidFileError = prism InvalidFileError $ \case + InvalidFileError e -> Right e + x -> Left x + + _InvalidIAMError = prism InvalidIAMError $ \case + InvalidIAMError e -> Right e + x -> Left x + +-- | Retrieve authentication information via the specified 'Credentials' mechanism. +-- +-- Throws 'AuthError' when environment variables or IAM profiles cannot be read. +getAuth :: (Applicative m, MonadIO m, MonadCatch m) + => Manager + -> Credentials + -> m Auth +getAuth m = \case + FromKeys a s -> return (fromKeys a s) + FromSession a s t -> return (fromSession a s t) + FromEnv a s t -> fromEnvKeys a s t + FromProfile n -> fromProfileName m n + FromFile n f -> fromFilePath n f + Discover -> + -- Don't try and catch InvalidFileError, or InvalidIAMProfile, + -- let both errors propagate. + catching_ _MissingEnvError fromEnv $ + -- proceed, missing env keys + catching _MissingFileError fromFile $ \f -> do + -- proceed, missing credentials file + p <- isEC2 m + unless p $ throwingM _MissingFileError f + fromProfile m + +-- | Retrieve access key, secret key, and a session token from the default +-- environment variables. +-- +-- Throws 'MissingEnvError' if either of the default environment variables +-- cannot be read, but not if the session token is absent. +-- +-- /See:/ 'envAccessKey', 'envSecretKey', 'envSessionToken' +fromEnv :: (Applicative m, MonadIO m, MonadThrow m) => m Auth +fromEnv = fromEnvKeys envAccessKey envSecretKey (Just envSessionToken) + +-- | Retrieve access key, secret key and a session token from specific +-- environment variables. +-- +-- Throws 'MissingEnvError' if either of the specified key environment variables +-- cannot be read, but not if the session token is absent. +fromEnvKeys :: (Applicative m, MonadIO m, MonadThrow m) + => Text -- ^ Access key environment variable. + -> Text -- ^ Secret key environment variable. + -> Maybe Text -- ^ Session token environment variable. + -> m Auth +fromEnvKeys a s t = fmap Auth $ AuthEnv + <$> (req a <&> AccessKey) + <*> (req s <&> SecretKey) + <*> (opt t <&> fmap SessionToken) + <*> pure Nothing + where + req k = do + m <- opt (Just k) + maybe (throwM . MissingEnvError $ "Unable to read ENV variable: " <> k) + return + m + + opt Nothing = return Nothing + opt (Just k) = fmap BS8.pack <$> liftIO (lookupEnv (Text.unpack k)) + +-- | Loads the default @credentials@ INI file using the default profile name. +-- +-- Throws 'MissingFileError' if 'credFile' is missing, or 'InvalidFileError' +-- if an error occurs during parsing. +-- +-- /See:/ 'credProfile' and 'credFile' +fromFile :: (Applicative m, MonadIO m, MonadCatch m) => m Auth +fromFile = credFile >>= fromFilePath credProfile + +-- | Retrieve the access, secret and session token from the specified section +-- (profile) in a valid INI @credentials@ file. +-- +-- Throws 'MissingFileError' if the specified file is missing, or 'InvalidFileError' +-- if an error occurs during parsing. +fromFilePath :: (Applicative m, MonadIO m, MonadCatch m) + => Text + -> FilePath + -> m Auth +fromFilePath n f = do + p <- liftIO (doesFileExist f) + unless p $ throwM (MissingFileError f) + i <- either (throwM . invalidErr) return =<< liftIO (INI.readIniFile f) + fmap Auth $ AuthEnv + <$> (req credAccessKey i <&> AccessKey) + <*> (req credSecretKey i <&> SecretKey) + <*> (opt credSessionToken i <&> fmap SessionToken) + <*> pure Nothing + where + req k i = + either (throwM . invalidErr) + (return . Text.encodeUtf8) + (INI.lookupValue n k i) + + opt k i = return $ + either (const Nothing) + (Just . Text.encodeUtf8) + (INI.lookupValue n k i) + + invalidErr :: String -> AuthError + invalidErr = InvalidFileError . Text.pack + +-- | Retrieve the default IAM Profile from the local EC2 instance-data. +-- +-- The default IAM profile is determined by Amazon as the first profile found +-- in the response from: +-- @http://169.254.169.254/latest/meta-data/iam/security-credentials/@ +-- +-- Throws 'RetrievalError' if the HTTP call fails, or 'InvalidIAMError' if +-- the default IAM profile cannot be read. +fromProfile :: (MonadIO m, MonadCatch m) => Manager -> m Auth +fromProfile m = do + ls <- try $ metadata m (IAM (SecurityCredentials Nothing)) + case BS8.lines `liftM` ls of + Right (x:_) -> fromProfileName m (Text.decodeUtf8 x) + Left e -> throwM (RetrievalError e) + _ -> throwM $ + InvalidIAMError "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. +-- +-- Throws 'RetrievalError' if the HTTP call fails, or 'InvalidIAMError' if +-- the specified IAM profile cannot be read. +fromProfileName :: (MonadIO m, MonadCatch m) => Manager -> Text -> m Auth +fromProfileName m name = auth >>= start + where + auth :: (MonadIO m, MonadCatch m) => m AuthEnv + auth = do + bs <- try $ metadata m (IAM . SecurityCredentials $ Just name) + case bs of + Left e -> throwM (RetrievalError e) + Right x -> + either (throwM . invalidErr) + return + (eitherDecode' (LBS8.fromStrict x)) + + invalidErr = InvalidIAMError + . mappend ("Error parsing IAM profile '" <> name <> "' ") + . Text.pack + + start :: MonadIO m => AuthEnv -> m Auth + start !a = 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 :: IORef AuthEnv -> ThreadId -> UTCTime -> IO ThreadId + timer !r !p !x = forkIO $ do + s <- myThreadId + w <- mkWeakIORef r (killThread s) + loop w p x + + loop :: Weak (IORef AuthEnv) -> ThreadId -> UTCTime -> IO () + loop w !p !x = do + diff x <$> getCurrentTime >>= threadDelay + ea <- try auth + case ea of + Left e -> throwTo p (RetrievalError 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) $ if n > 0 then n else 1 + where + !n = truncate (diffUTCTime x y) - 60 diff --git a/src/Network/AWS/Data.hs b/src/Network/AWS/Data.hs new file mode 100644 --- /dev/null +++ b/src/Network/AWS/Data.hs @@ -0,0 +1,32 @@ +-- | +-- Module : Network.AWS.Data +-- Copyright : (c) 2013-2015 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +-- +-- Re-exports some of the underlying textual and byte serialisation mechanisms +-- for convenience. +-- +-- Many of the AWS identifiers like S3's 'ObjectVersionId' or 'ETag', +-- as well as any nullary sum types such as 'Network.AWS.Region' have 'ToText' +-- and 'ToByteString' instances, making it convenient to use the type classes +-- to convert a value to its textual representation. +module Network.AWS.Data + ( + -- * Text + FromText (..) + , fromText + , ToText (..) + + -- * ByteString + , ToByteString (..) + + -- * Log Messages + , ToLog (..) + ) where + +import Network.AWS.Data.ByteString +import Network.AWS.Data.Log +import Network.AWS.Data.Text diff --git a/src/Network/AWS/EC2/Metadata.hs b/src/Network/AWS/EC2/Metadata.hs --- a/src/Network/AWS/EC2/Metadata.hs +++ b/src/Network/AWS/EC2/Metadata.hs @@ -1,55 +1,58 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +-- | -- Module : Network.AWS.EC2.Metadata --- Copyright : (c) 2013-2015 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/. +-- Copyright : (c) 2013-2015 Brendan Hay +-- License : Mozilla Public License, v. 2.0. -- Maintainer : Brendan Hay --- Stability : experimental +-- Stability : provisional -- Portability : non-portable (GHC extensions) - --- | Retrieve an EC2 instance's local metadata. +-- +-- This module contains functions for retrieving various EC2 metadata from an +-- instance's local metadata endpoint using 'MonadIO' and not one of the AWS +-- specific transformers. +-- +-- It is intended to be used when you need to make metadata calls prior to +-- initialisation of the 'Network.AWS.Env.Env'. +-- If you wish to retrieve instance metadata during normal operations +-- and are using either the 'Network.AWS.AWS' or 'Control.Monad.Trans.AWS.AWST' +-- monads, then prefer one of the 'Control.Monad.Trans.AWS.metadata' related +-- functions available there, as the functions in this module do not use the +-- underlying 'FreeT' 'Network.AWS.Free.Command' DSL. module Network.AWS.EC2.Metadata ( - -- * Requests - -- ** Running on EC2 + -- * EC2 Instance Check isEC2 - -- ** Dynamic - , Dynamic (..) + -- * Retrieving Instance Data , dynamic + , metadata + , userdata - -- ** Metadata + -- ** Path Constructors + , Dynamic (..) , Metadata (..) , Mapping (..) , Info (..) , Interface (..) - , metadata - - -- ** User data - , userdata ) where -import Control.Applicative -import Control.Exception import Control.Monad -import Control.Monad.Error (catchError, throwError) +import Control.Monad.Catch import Control.Monad.IO.Class -import Control.Monad.Trans.Except -import Data.ByteString (ByteString) -import qualified Data.ByteString.Char8 as BS -import qualified Data.ByteString.Lazy as LBS -import Data.Maybe +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.ByteString.Lazy as LBS import Data.Monoid -import Data.Text (Text) -import qualified Data.Text as Text -import Network.AWS.Data +import qualified Data.Text as Text +import Network.AWS.Prelude hiding (request) import Network.HTTP.Conduit +import Prelude + data Dynamic = FWS -- ^ Value showing whether the customer has enabled detailed one-minute @@ -63,13 +66,14 @@ -- ^ Used to verify the document's authenticity and content against the -- signature. | Signature + deriving (Eq, Ord, Show, Typeable) -instance ToPath Dynamic where - toPath x = case x of - FWS -> "fws/instance-monitoring" - Document -> "instance-identity/document" - PKCS7 -> "instance-identity/pkcs7" - Signature -> "instance-identity/signature" +instance ToText Dynamic where + toText = \case + FWS -> "dynamic/fws/instance-monitoring" + Document -> "dynamic/instance-identity/document" + PKCS7 -> "dynamic/instance-identity/pkcs7" + Signature -> "dynamic/instance-identity/signature" data Metadata = AMIId @@ -138,33 +142,33 @@ -- ^ ID of the reservation. | SecurityGroups -- ^ The names of the security groups applied to the instance. - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show, Typeable) -instance ToPath Metadata where - toPath x = case x of - AMIId -> "ami-id" - AMILaunchIndex -> "ami-launch-index" - AMIManifestPath -> "ami-manifest-path" - AncestorAMIIds -> "ancestor-ami-ids" - BlockDevice m -> "block-device-mapping/" <> toPath m - Hostname -> "hostname" - IAM m -> "iam/" <> toPath m - InstanceAction -> "instance-action" - InstanceId -> "instance-id" - InstanceType -> "instance-type" - KernelId -> "kernel-id" - LocalHostname -> "local-hostname" - LocalIPV4 -> "local-ipv4" - MAC -> "mac" - Network n m -> "network/interfaces/macs/" <> n <> "/" <> toPath m - AvailabilityZone -> "placement/availability-zone" - ProductCodes -> "product-codes" - PublicHostname -> "public-hostname" - PublicIPV4 -> "public-ipv4" - OpenSSHKey -> "public-keys/0/openssh-key" - RAMDiskId -> "ramdisk-id" - ReservationId -> "reservation-id" - SecurityGroups -> "security-groups" +instance ToText Metadata where + toText = \case + AMIId -> "meta-data/ami-id" + AMILaunchIndex -> "meta-data/ami-launch-index" + AMIManifestPath -> "meta-data/ami-manifest-path" + AncestorAMIIds -> "meta-data/ancestor-ami-ids" + BlockDevice m -> "meta-data/block-device-mapping/" <> toText m + Hostname -> "meta-data/hostname" + IAM m -> "meta-data/iam/" <> toText m + InstanceAction -> "meta-data/instance-action" + InstanceId -> "meta-data/instance-id" + InstanceType -> "meta-data/instance-type" + KernelId -> "meta-data/kernel-id" + LocalHostname -> "meta-data/local-hostname" + LocalIPV4 -> "meta-data/local-ipv4" + MAC -> "meta-data/mac" + Network n m -> "meta-data/network/interfaces/macs/" <> toText n <> "/" <> toText m + AvailabilityZone -> "meta-data/placement/availability-zone" + ProductCodes -> "meta-data/product-codes" + PublicHostname -> "meta-data/public-hostname" + PublicIPV4 -> "meta-data/public-ipv4" + OpenSSHKey -> "meta-data/public-keys/0/openssh-key" + RAMDiskId -> "meta-data/ramdisk-id" + ReservationId -> "meta-data/reservation-id" + SecurityGroups -> "meta-data/security-groups" data Mapping = AMI @@ -182,10 +186,10 @@ -- is associated with the given instance. | Swap -- ^ The virtual devices associated with swap. Not always present. - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show, Typeable) -instance ToPath Mapping where - toPath x = case x of +instance ToText Mapping where + toText = \case AMI -> "ami" EBS n -> "ebs" <> toText n Ephemeral n -> "ephemeral" <> toText n @@ -237,12 +241,12 @@ | IVPCIPV4_CIDRBlock -- ^ The CIDR block of the VPC in which the interface resides. Returned only -- for instances launched into a VPC. - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show, Typeable) -instance ToPath Interface where - toPath x = case x of +instance ToText Interface where + toText = \case IDeviceNumber -> "device-number" - IIPV4Associations ip -> "ipv4-associations/" <> ip + IIPV4Associations ip -> "ipv4-associations/" <> toText ip ILocalHostname -> "local-hostname" ILocalIPV4s -> "local-ipv4s" IMAC -> "mac" @@ -257,7 +261,7 @@ IVPCIPV4_CIDRBlock -> "vpc-ipv4-cidr-block" data Info - = Info + = Info' -- ^ Returns information about the last time the instance profile was updated, -- including the instance's LastUpdated date, InstanceProfileArn, -- and InstanceProfileId. @@ -266,15 +270,19 @@ -- Returns the temporary security credentials. -- -- See: 'Auth' for JSON deserialisation. - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show, Typeable) -instance ToPath Info where - toPath x = case x of - Info -> "info" - SecurityCredentials r -> "security-credentials/" <> fromMaybe "" r +instance ToText Info where + toText = \case + Info' -> "info" + SecurityCredentials r -> "security-credentials/" <> maybe mempty toText r --- | Test whether the host is running on EC2 by requesting the instance-data. -isEC2 :: Manager -> IO Bool +latest :: Text +latest = "http://169.254.169.254/latest/" + +-- | Test whether the underlying host is running on EC2 by +-- making an HTTP request to @http://instance-data/latest@. +isEC2 :: MonadIO m => Manager -> m Bool isEC2 m = liftIO (req `catch` err) where req = do @@ -284,43 +292,37 @@ err :: HttpException -> IO Bool err = const (return False) -dynamic :: MonadIO m - => Manager - -> Dynamic - -> ExceptT HttpException m ByteString -dynamic m = get m . mappend "http://169.254.169.254/latest/dynamic/" . toPath +-- | Retrieve the specified 'Dynamic' data. +-- +-- Throws 'HttpException' if HTTP communication fails. +dynamic :: (MonadIO m, MonadThrow m) => Manager -> Dynamic -> m ByteString +dynamic m = get m . mappend latest . toText -metadata :: MonadIO m - => Manager - -> Metadata - -> ExceptT HttpException m ByteString -metadata m = get m . mappend "http://169.254.169.254/latest/meta-data/" . toPath +-- | Retrieve the specified 'Metadata'. +-- +-- Throws 'HttpException' if HTTP communication fails. +metadata :: (MonadIO m, MonadThrow m) => Manager -> Metadata -> m ByteString +metadata m = get m . mappend latest . toText -userdata :: MonadIO m - => Manager - -> ExceptT HttpException m (Maybe ByteString) -userdata m = Just - `liftM` get m "http://169.254.169.254/latest/user-data" - `catchError` err - where - err (StatusCodeException s _ _) | fromEnum s == 404 - = return Nothing - err e = throwError e +-- | Retrieve the user data. Returns 'Nothing' if no user data is assigned +-- to the instance. +-- +-- Throws 'HttpException' if HTTP communication fails. +userdata :: (MonadIO m, MonadCatch m) => Manager -> m (Maybe ByteString) +userdata m = do + x <- try $ get m (latest <> "user-data") + case x of + Right b -> return (Just b) + Left (StatusCodeException s _ _) + | fromEnum s == 404 -> return Nothing + Left e -> throwM e -get :: MonadIO m - => Manager - -> Text - -> ExceptT HttpException m ByteString -get m url = ExceptT . liftIO $ req `catch` err +get :: (MonadIO m, MonadThrow m) => Manager -> Text -> m ByteString +get m url = liftIO (strip `liftM` request m url) where - req = Right . strip <$> request m url - strip bs - | BS.isSuffixOf "\n" bs = BS.init bs - | otherwise = bs - - err :: HttpException -> IO (Either HttpException a) - err = return . Left + | BS8.isSuffixOf "\n" bs = BS8.init bs + | otherwise = bs request :: Manager -> Text -> IO ByteString request m url = do diff --git a/src/Network/AWS/Env.hs b/src/Network/AWS/Env.hs new file mode 100644 --- /dev/null +++ b/src/Network/AWS/Env.hs @@ -0,0 +1,168 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} + +-- | +-- Module : Network.AWS.Env +-- Copyright : (c) 2013-2015 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +-- +-- Environment and AWS specific configuration for the +-- 'Network.AWS.AWS' and 'Control.Monad.Trans.AWS.AWST' monads. +module Network.AWS.Env + ( + -- * Creating the Environment + newEnv + , newEnvWith + + , Env (..) + , HasEnv (..) + + -- * Scoped Actions + , within + , once + , timeout + ) where + +import Control.Applicative +import Control.Lens +import Control.Monad +import Control.Monad.Catch +import Control.Monad.IO.Class +import Control.Monad.Reader +import Control.Retry +import Data.IORef +import Data.Monoid +import Network.AWS.Auth +import Network.AWS.Internal.Logger +import Network.AWS.Types +import Network.HTTP.Conduit + +import Prelude + +-- | The environment containing the parameters required to make AWS requests. +data Env = Env + { _envRegion :: !Region + , _envLogger :: !Logger + , _envRetryCheck :: !(Int -> HttpException -> IO Bool) + , _envRetryPolicy :: !(Maybe RetryPolicy) + , _envTimeout :: !(Maybe Seconds) + , _envManager :: !Manager + , _envEC2 :: !(IORef (Maybe Bool)) + , _envAuth :: !Auth + } + +-- Note: The strictness annotations aobe are applied to ensure +-- total field initialisation. + +class HasEnv a where + environment :: Lens' a Env + {-# MINIMAL environment #-} + + -- | The current region. + envRegion :: Lens' a Region + + -- | The function used to output log messages. + envLogger :: Lens' a Logger + + -- | The function used to determine if an 'HttpException' should be retried. + envRetryCheck :: Lens' a (Int -> HttpException -> IO Bool) + + -- | The 'RetryPolicy' used to determine backoff\/on and retry delay\/growth. + envRetryPolicy :: Lens' a (Maybe RetryPolicy) + + -- | A HTTP response timeout override to apply. This defaults to 'Nothing', + -- and the timeout selection is outlined below. + -- + -- Timeouts are chosen by considering: + -- + -- * This 'envTimeout', if set. + -- + -- * The related 'Service' timeout for the sent request if set. (Usually 70s) + -- + -- * The 'envManager' timeout if set. + -- + -- * The default 'ClientRequest' timeout. (Approximately 30s) + -- + envTimeout :: Lens' a (Maybe Seconds) + + -- | The 'Manager' used to create and manage open HTTP connections. + envManager :: Lens' a Manager + + -- | The credentials used to sign requests for authentication with AWS. + envAuth :: Lens' a Auth + + -- | A memoised predicate for whether the underlying host is an EC2 instance. + envEC2 :: Getter a (IORef (Maybe Bool)) + + envRegion = environment . lens _envRegion (\s a -> s { _envRegion = a }) + envLogger = environment . lens _envLogger (\s a -> s { _envLogger = a }) + envRetryCheck = environment . lens _envRetryCheck (\s a -> s { _envRetryCheck = a }) + envRetryPolicy = environment . lens _envRetryPolicy (\s a -> s { _envRetryPolicy = a }) + envTimeout = environment . lens _envTimeout (\s a -> s { _envTimeout = a }) + envManager = environment . lens _envManager (\s a -> s { _envManager = a }) + envAuth = environment . lens _envAuth (\s a -> s { _envAuth = a }) + envEC2 = environment . to _envEC2 + +instance HasEnv Env where + environment = id + +instance ToLog Env where + build Env{..} = b <> "\n" <> build _envAuth + where + b = buildLines + [ "[Amazonka Env] {" + , " region = " <> build _envRegion + , " retry (n=0) = " <> build (join $ ($ 0) . getRetryPolicy <$> _envRetryPolicy) + , " timeout = " <> build _envTimeout + , "}" + ] + +-- | Scope an action within the specific 'Region'. +within :: (MonadReader r m, HasEnv r) => Region -> m a -> m a +within r = local (envRegion .~ r) + +-- | Scope an action such that any retry logic for the 'Service' is +-- ignored and any requests will at most be sent once. +once :: (MonadReader r m, HasEnv r) => m a -> m a +once = local $ \e -> e + & envRetryPolicy ?~ limitRetries 0 + & envRetryCheck .~ (\_ _ -> return False) + +-- | Scope an action such that any HTTP response will use this timeout value. +timeout :: (MonadReader r m, HasEnv r) => Seconds -> m a -> m a +timeout s = local (envTimeout ?~ s) + +-- | Creates a new environment with a new 'Manager' without debug logging +-- and uses 'getAuth' to expand/discover the supplied 'Credentials'. +-- Lenses from 'HasEnv' can be used to further configure the resulting 'Env'. +-- +-- Throws 'AuthError' when environment variables or IAM profiles cannot be read. +-- +-- /See:/ 'newEnvWith'. +newEnv :: (Applicative m, MonadIO m, MonadCatch m) + => Region -- ^ Initial region to operate in. + -> Credentials -- ^ Credential discovery mechanism. + -> m Env +newEnv r c = liftIO (newManager conduitManagerSettings) + >>= newEnvWith r c Nothing + +-- | /See:/ 'newEnv' +-- +-- Throws 'AuthError' when environment variables or IAM profiles cannot be read. +newEnvWith :: (Applicative m, MonadIO m, MonadCatch m) + => Region -- ^ Initial region to operate in. + -> Credentials -- ^ Credential discovery mechanism. + -> Maybe Bool -- ^ Preload memoisation for the underlying EC2 instance check. + -> Manager + -> m Env +newEnvWith r c p m = Env r logger check Nothing Nothing m + <$> liftIO (newIORef p) + <*> getAuth m c + where + logger _ _ = return () + -- FIXME: verify the usage of check. + check _ _ = return True diff --git a/src/Network/AWS/Free.hs b/src/Network/AWS/Free.hs new file mode 100644 --- /dev/null +++ b/src/Network/AWS/Free.hs @@ -0,0 +1,196 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} + +-- | +-- Module : Network.AWS.Free +-- Copyright : (c) 2013-2015 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +-- +-- Defines the core AST, logic and interpreters for AWS behaviour. +module Network.AWS.Free where + +import Control.Applicative +import Control.Monad.Reader +import Control.Monad.Trans.Free.Church +import Data.Conduit (Source, yield) +import Network.AWS.EC2.Metadata (Dynamic, Metadata) +import Network.AWS.Pager +import Network.AWS.Prelude +import Network.AWS.Request (requestURL) +import Network.AWS.Types +import Network.AWS.Waiter + +#if MIN_VERSION_free(4,12,0) +#else +import Control.Monad.Catch +import Control.Monad.Trans.Free (FreeT (..)) +#endif + +import Prelude + +data Command r where + CheckF :: (Bool -> r) -> Command r + DynF :: Dynamic -> (ByteString -> r) -> Command r + MetaF :: Metadata -> (ByteString -> r) -> Command r + UserF :: (Maybe ByteString -> r) -> Command r + + SignF :: (AWSPresigner (Sg s), AWSRequest a) + => Service s + -> UTCTime + -> Seconds + -> a + -> (ClientRequest -> r) + -> Command r + + SendF :: (AWSSigner (Sg s), AWSRequest a) + => Service s + -> a + -> (Rs a -> r) + -> Command r + + AwaitF :: (AWSSigner (Sg s), AWSRequest a) + => Service s + -> Wait a + -> a + -> (Rs a -> r) + -> Command r + +instance Functor Command where + fmap f = \case + CheckF k -> CheckF (fmap f k) + DynF x k -> DynF x (fmap f k) + MetaF x k -> MetaF x (fmap f k) + UserF k -> UserF (fmap f k) + SignF s t e x k -> SignF s t e x (fmap f k) + SendF s x k -> SendF s x (fmap f k) + AwaitF s w x k -> AwaitF s w x (fmap f k) + +#if MIN_VERSION_free(4,12,0) +#else +instance MonadThrow m => MonadThrow (FreeT Command m) where + throwM = lift . throwM + +instance MonadCatch m => MonadCatch (FreeT Command m) where + catch (FreeT m) f = FreeT $ + liftM (fmap (`catch` f)) m `catch` (runFreeT . f) +#endif + +-- | Send a request, returning the associated response if successful. +-- +-- /See:/ 'sendWith' +send :: (MonadFree Command m, AWSRequest a) + => a + -> m (Rs a) +send = sendWith id + +-- | A variant of 'send' that allows modifying the default 'Service' definition +-- used to configure the request. +sendWith :: (MonadFree Command m, AWSSigner (Sg s), AWSRequest a) + => (Service (Sv a) -> Service s) -- ^ Modify the default service configuration. + -> a -- ^ Request. + -> m (Rs a) +sendWith f x = liftF (SendF (f (serviceOf x)) x id) + +-- | Repeatedly send a request, automatically setting markers and +-- paginating over multiple responses while available. +-- +-- /See:/ 'paginateWith' +paginate :: (MonadFree Command m, AWSPager a) + => a + -> Source m (Rs a) +paginate = paginateWith id + +-- | A variant of 'paginate' that allows modifying the default 'Service' definition +-- used to configure the request. +paginateWith :: (MonadFree Command m, AWSSigner (Sg s), AWSPager a) + => (Service (Sv a) -> Service s) -- ^ Modify the default service configuration. + -> a -- ^ Initial request. + -> Source m (Rs a) +paginateWith f rq = go rq + where + go !x = do + !y <- lift $ liftF (SendF s x id) + yield y + maybe (pure ()) + go + (page x y) + + !s = f (serviceOf rq) + +-- | Poll the API with the supplied request until a specific 'Wait' condition +-- is fulfilled. +-- +-- /See:/ 'awaitWith' +await :: (MonadFree Command m, AWSRequest a) + => Wait a + -> a + -> m (Rs a) +await = awaitWith id + +-- | A variant of 'await' that allows modifying the default 'Service' definition +-- used to configure the request. +awaitWith :: (MonadFree Command m, AWSSigner (Sg s), AWSRequest a) + => (Service (Sv a) -> Service s) -- ^ Modify the default service configuration. + -> Wait a -- ^ Polling, error and acceptance criteria. + -> a -- ^ Request to poll with. + -> m (Rs a) +awaitWith f w x = liftF (AwaitF (f (serviceOf x)) w x id) + +-- | Presign an URL that is valid from the specified time until the +-- number of seconds expiry has elapsed. +-- +-- /See:/ 'presign', 'presignWith' +presignURL :: (MonadFree Command m, AWSPresigner (Sg (Sv a)), AWSRequest a) + => UTCTime -- ^ Signing time. + -> Seconds -- ^ Expiry time. + -> a -- ^ Request to presign. + -> m ByteString +presignURL ts ex = liftM requestURL . presign ts ex + +-- | Presign an HTTP request that is valid from the specified time until the +-- number of seconds expiry has elapsed. +-- +-- /See:/ 'presignWith' +presign :: (MonadFree Command m, AWSPresigner (Sg (Sv a)), AWSRequest a) + => UTCTime -- ^ Signing time. + -> Seconds -- ^ Expiry time. + -> a -- ^ Request to presign. + -> m ClientRequest +presign = presignWith id + +-- | A variant of 'presign' that allows specifying the 'Service' definition +-- used to configure the request. +presignWith :: (MonadFree Command m, AWSPresigner (Sg s), AWSRequest a) + => (Service (Sv a) -> Service s) -- ^ Function to modify the service configuration. + -> UTCTime -- ^ Signing time. + -> Seconds -- ^ Expiry time. + -> a -- ^ Request to presign. + -> m ClientRequest +presignWith f ts ex x = liftF (SignF (f (serviceOf x)) ts ex x id) + +-- | Test whether the underlying host is running on EC2. +-- For 'IO' based interpretations of 'FreeT' 'Command', this is memoised and +-- any external check occurs for the first call only. +isEC2 :: MonadFree Command m => m Bool +isEC2 = liftF (CheckF id) + +-- | Retrieve the specified 'Dynamic' data. +dynamic :: MonadFree Command m => Dynamic -> m ByteString +dynamic d = liftF (DynF d id) + +-- | Retrieve the specified 'Metadata'. +metadata :: MonadFree Command m => Metadata -> m ByteString +metadata m = liftF (MetaF m id) + +-- | Retrieve the user data. Returns 'Nothing' if no user data is assigned +-- to the instance. +userdata :: MonadFree Command m => m (Maybe ByteString) +userdata = liftF (UserF id) diff --git a/src/Network/AWS/Internal/Auth.hs b/src/Network/AWS/Internal/Auth.hs deleted file mode 100644 --- a/src/Network/AWS/Internal/Auth.hs +++ /dev/null @@ -1,194 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ViewPatterns #-} - --- Module : Network.AWS.Internal.Auth --- Copyright : (c) 2013-2015 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 -import Control.Monad.Error (catchError, throwError) -import Control.Monad.IO.Class -import Control.Monad.Trans.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 (diffUTCTime, getCurrentTime) -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/Body.hs b/src/Network/AWS/Internal/Body.hs --- a/src/Network/AWS/Internal/Body.hs +++ b/src/Network/AWS/Internal/Body.hs @@ -1,29 +1,29 @@ +-- | -- Module : Network.AWS.Internal.Body --- Copyright : (c) 2013-2015 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/. +-- Copyright : (c) 2013-2015 Brendan Hay +-- License : Mozilla Public License, v. 2.0. -- Maintainer : Brendan Hay --- Stability : experimental +-- Stability : provisional -- Portability : non-portable (GHC extensions) - +-- module Network.AWS.Internal.Body where import Control.Applicative +import Control.Monad import Control.Monad.IO.Class +import Control.Monad.Morph import Control.Monad.Trans.Resource -import Crypto.Hash -import qualified Crypto.Hash.Conduit as Conduit -import Data.ByteString (ByteString) import Data.Conduit import qualified Data.Conduit.Binary as Conduit import Data.Int -import Network.AWS.Data +import Network.AWS.Prelude +import qualified Network.HTTP.Client as Client import Network.HTTP.Conduit import System.IO --- | Unsafely construct a 'RqBody' from a source, manually specifying the +import Prelude + +-- | Construct a 'RqBody' from a source, manually specifying the -- SHA256 hash and file size. sourceBody :: Digest SHA256 -> Int64 @@ -31,24 +31,47 @@ -> RqBody sourceBody h n = RqBody h . requestBodySource n --- | Unsafely construct a 'RqBody' from a 'Handle', manually specifying the +-- | Construct a 'RqBody' from a 'Handle', manually specifying the -- SHA256 hash and file size. sourceHandle :: Digest SHA256 -> Int64 -> Handle -> RqBody sourceHandle h n = sourceBody h n . Conduit.sourceHandle --- | Unsafely construct a 'RqBody' from a 'FilePath', manually specifying the +-- | Construct a 'RqBody' from a 'FilePath', manually specifying the -- SHA256 hash and file size. sourceFile :: Digest SHA256 -> Int64 -> FilePath -> RqBody sourceFile h n = sourceBody h n . Conduit.sourceFile --- | Safely construct a 'RqBody' from a 'FilePath', calculating the SHA256 hash +-- | Construct a 'RqBody' from a 'FilePath', calculating the SHA256 hash -- and file size. -- --- /Note:/ While this function will perform in constant space, it will read the +-- /Note:/ While this function will perform in constant space, it will enumerate the -- entirety of the file contents _twice_. Firstly to calculate the SHA256 and -- lastly to stream the contents to the socket during sending. sourceFileIO :: MonadIO m => FilePath -> m RqBody -sourceFileIO f = liftIO $ sourceFile - <$> runResourceT (Conduit.sourceFile f $$ Conduit.sinkHash) - <*> fmap fromIntegral (withBinaryFile f ReadMode hFileSize) - <*> pure f +sourceFileIO f = liftIO $ + RqBody <$> runResourceT (Conduit.sourceFile f $$ sinkSHA256) + <*> Client.streamFile f + +-- | Convenience function for obtaining the size of a file. +getFileSize :: MonadIO m => FilePath -> m Int64 +getFileSize f = liftIO $ fromIntegral `liftM` withBinaryFile f ReadMode hFileSize + +-- | Connect a 'Sink' to a reponse body. +sinkBody :: MonadResource m => RsBody -> Sink ByteString m a -> m a +sinkBody (RsBody src) sink = hoist liftResourceT src $$+- sink + +sinkMD5 :: Monad m => Consumer ByteString m (Digest MD5) +sinkMD5 = sinkHash + +sinkSHA256 :: Monad m => Consumer ByteString m (Digest SHA256) +sinkSHA256 = sinkHash + +-- | A cryptonite compatible incremental hash sink. +sinkHash :: (Monad m, HashAlgorithm a) => Consumer ByteString m (Digest a) +sinkHash = sink hashInit + where + sink ctx = do + b <- await + case b of + Nothing -> return $! hashFinalize ctx + Just bs -> sink $! hashUpdate ctx bs diff --git a/src/Network/AWS/Internal/Env.hs b/src/Network/AWS/Internal/Env.hs deleted file mode 100644 --- a/src/Network/AWS/Internal/Env.hs +++ /dev/null @@ -1,80 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} - --- Module : Network.AWS.Internal.Env --- Copyright : (c) 2013-2015 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.Env where - -import Control.Lens -import Control.Retry -import qualified Data.ByteString.Lazy.Char8 as LBS -import Data.List (intersperse) -import Data.Monoid -import Network.AWS.Data (ToBuilder(..), buildBS) -import Network.AWS.Types -import Network.HTTP.Conduit - --- | The environment containing the parameters required to make AWS requests. -data Env = Env - { _envRegion :: !Region - , _envLogger :: Logger - , _envRetryCheck :: Int -> HttpException -> IO Bool - , _envRetryPolicy :: Maybe RetryPolicy - , _envManager :: Manager - , _envAuth :: Auth - } - --- | 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" - [ "[Amazonka Env] {" - , " region = " <> build _envRegion - , " retry (n=0) = " <> maybe "Nothing" policy _envRetryPolicy - , build . indent $ buildBS _envAuth - , "}" - ] - where - policy (RetryPolicy f) = "Just " <> build (f 0) - - indent = mappend " " - . LBS.concat - . intersperse "\n " - . LBS.lines diff --git a/src/Network/AWS/Internal/HTTP.hs b/src/Network/AWS/Internal/HTTP.hs new file mode 100644 --- /dev/null +++ b/src/Network/AWS/Internal/HTTP.hs @@ -0,0 +1,143 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Module : Network.AWS.Internal.HTTP +-- Copyright : (c) 2013-2015 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +-- +module Network.AWS.Internal.HTTP + ( perform + , retrier + , waiter + ) where + +import Control.Monad +import Control.Monad.Catch +import Control.Monad.IO.Class +import Control.Monad.Trans.Resource +import Control.Retry +import Data.List (intersperse) +import Data.Monoid +import Data.Time +import Network.AWS.Env +import Network.AWS.Internal.Logger +import Network.AWS.Prelude +import Network.AWS.Waiter +import Network.HTTP.Conduit hiding (Request, Response) + +import Prelude + +perform :: (MonadCatch m, MonadResource m, AWSSigner (Sg s), AWSRequest a) + => Env + -> Service s + -> Request a + -> m (Either Error (Response a)) +perform e@Env{..} svc x = catches go handlers + where + go = do + t <- liftIO getCurrentTime + Signed m s <- withAuth _envAuth $ \a -> + return (signed a _envRegion t svc x) + + let rq = s { responseTimeout = timeoutFor e svc } + + logTrace _envLogger m -- trace:Signing:Meta + logDebug _envLogger rq -- debug:ClientRequest + + rs <- liftResourceT (http rq _envManager) + + logDebug _envLogger rs -- debug:ClientResponse + + Right <$> + response _envLogger svc x rs + + handlers = + [ Handler $ return . Left + , Handler $ \er -> do + logError _envLogger er + return (Left (TransportError er)) + ] + +retrier :: MonadIO m + => Env + -> Service s + -> Request a + -> m (Either Error (Response a)) + -> m (Either Error (Response a)) +retrier Env{..} Service{..} rq = + retrying (fromMaybe policy _envRetryPolicy) check + where + policy = limitRetries _retryAttempts + <> RetryPolicy (const $ listToMaybe [0 | not stream]) + <> RetryPolicy delay + where + !stream = bodyStream (_rqBody rq) + + delay n + | n > 0 = Just $ truncate (grow * 1000000) + | otherwise = Nothing + where + grow = _retryBase * (fromIntegral _retryGrowth ^^ (n - 1)) + + check n = \case + Left (TransportError e) -> do + p <- liftIO (_envRetryCheck n e) + when p (msg "http_error" n) >> return p + + Left e | Just x <- e ^? _ServiceError . to _retryCheck . _Just -> + msg x n >> return True + + _ -> return False + + msg x n = logDebug _envLogger + . mconcat + . intersperse " " + $ [ "[Retry " <> build x <> "]" + , " after " + , build (n + 1) + , "attempts." + ] + + Exponential{..} = _svcRetry + +waiter :: MonadIO m + => Env + -> Wait a + -> Request a + -> m (Either Error (Response a)) + -> m (Either Error (Response a)) +waiter Env{..} w@Wait{..} rq = retrying policy check + where + policy = limitRetries _waitAttempts + <> constantDelay (microseconds _waitDelay) + + 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 = logDebug _envLogger + . mconcat + . intersperse " " + $ [ "[Await " <> build _waitName <> "]" + , build a + , " after " + , build (n + 1) + , "attempts." + ] + +-- | Returns the possible HTTP response timeout value in microseconds +-- given the timeout configuration sources. +timeoutFor :: HasEnv a => a -> Service s -> Maybe Int +timeoutFor e s = microseconds <$> (e ^. envTimeout <|> _svcTimeout s) diff --git a/src/Network/AWS/Internal/Log.hs b/src/Network/AWS/Internal/Log.hs deleted file mode 100644 --- a/src/Network/AWS/Internal/Log.hs +++ /dev/null @@ -1,46 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- Module : Network.AWS.Internal.Log --- Copyright : (c) 2013-2015 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 -import Control.Monad.IO.Class -import Data.ByteString.Builder -import Data.Monoid -import Network.AWS.Data -import Network.AWS.Types -import System.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 - return $ \y b -> - when (x >= y) $ - hPutBuilder hd (b <> "\n") - -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 #-} diff --git a/src/Network/AWS/Internal/Logger.hs b/src/Network/AWS/Internal/Logger.hs new file mode 100644 --- /dev/null +++ b/src/Network/AWS/Internal/Logger.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : Network.AWS.Internal.Logger +-- Copyright : (c) 2013-2015 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +-- +-- Types and functions for constructing loggers and emitting log messages. +module Network.AWS.Internal.Logger + ( + -- * Constructing a Logger + Logger + , newLogger + + -- * Levels + , LogLevel (..) + , logError + , logInfo + , logDebug + , logTrace + + -- * Building Messages + , ToLog (..) + , buildLines + ) where + +import Control.Monad +import Control.Monad.IO.Class +import qualified Data.ByteString.Lazy.Builder as Build +import Data.Monoid +import Network.AWS.Data.Log +import Network.AWS.Types +import System.IO + +import Prelude + +-- | This is a primitive logger which can be used to log builds to a 'Handle'. +-- +-- /Note:/ A more sophisticated logging library such as +-- or +-- +-- should be used in production code. +newLogger :: MonadIO m => LogLevel -> Handle -> m Logger +newLogger x hd = liftIO $ do + hSetBinaryMode hd True + hSetBuffering hd LineBuffering + return $ \y b -> + when (x >= y) $ + Build.hPutBuilder hd (b <> "\n") + +logError, logInfo, logDebug, logTrace + :: (MonadIO m, ToLog a) => Logger -> a -> m () +logError f = liftIO . f Error . build +logInfo f = liftIO . f Info . build +logDebug f = liftIO . f Debug . build +logTrace f = liftIO . f Trace . build diff --git a/src/Network/AWS/Internal/Retry.hs b/src/Network/AWS/Internal/Retry.hs deleted file mode 100644 --- a/src/Network/AWS/Internal/Retry.hs +++ /dev/null @@ -1,91 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} - --- Module : Network.AWS.Internal.Retry --- Copyright : (c) 2013-2015 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." - ] diff --git a/src/Network/AWS/Presign.hs b/src/Network/AWS/Presign.hs new file mode 100644 --- /dev/null +++ b/src/Network/AWS/Presign.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE FlexibleContexts #-} + +-- | +-- Module : Network.AWS.Presign +-- Copyright : (c) 2013-2015 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +-- +-- This module contains functions for presigning requests using 'MonadIO' and +-- not one of the AWS specific transformers. +-- +-- It is intended for use directly with "Network.AWS.Auth" when only presigning +-- and no other AWS actions are required. +-- If you wish to presign requests and are using either the 'Network.AWS.AWS' +-- or 'Control.Monad.Trans.AWS.AWST' monads, then prefer one of the relevant +-- 'Control.Monad.Trans.AWS.presign'ing functions available there, as the +-- functions in this module do not use the underlying 'FreeT' +-- 'Network.AWS.Free.Command' DSL. +module Network.AWS.Presign where + +import Control.Lens +import Control.Monad +import Control.Monad.IO.Class +import Network.AWS.Data.Time +import Network.AWS.Prelude +import Network.AWS.Request (requestURL) +import Network.AWS.Types + +import Prelude + +-- | Presign an URL that is valid from the specified time until the +-- number of seconds expiry has elapsed. +-- +-- /See:/ 'presign', 'presignWith' +presignURL :: (MonadIO m, AWSPresigner (Sg (Sv a)), AWSRequest a) + => Auth + -> Region + -> UTCTime -- ^ Signing time. + -> Seconds -- ^ Expiry time. + -> a -- ^ Request to presign. + -> m ByteString +presignURL a r e ts = liftM requestURL . presign a r e ts + +-- | Presign an HTTP request that is valid from the specified time until the +-- number of seconds expiry has elapsed. +-- +-- This requires the 'Service' signer to be an instance of 'AWSPresigner'. +-- Not all signing algorithms support this. +-- +-- /See:/ 'presignWith' +presign :: (MonadIO m, AWSPresigner (Sg (Sv a)), AWSRequest a) + => Auth + -> Region + -> UTCTime -- ^ Signing time. + -> Seconds -- ^ Expiry time. + -> a -- ^ Request to presign. + -> m ClientRequest +presign a r ts ex = presignWith id a r ts ex + +-- | A variant of 'presign' that allows specifying the 'Service' definition +-- used to configure the request. +presignWith :: (MonadIO m, AWSPresigner (Sg s), AWSRequest a) + => (Service (Sv a) -> Service s) -- ^ Modify the default service configuration. + -> Auth + -> Region + -> UTCTime -- ^ Signing time. + -> Seconds -- ^ Expiry time. + -> a -- ^ Request to presign. + -> m ClientRequest +presignWith s a r ts ex x = + withAuth a $ \ae -> + return . view sgRequest $ + presigned ae r ts ex (s (serviceOf x)) (request x) diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,16 @@ +-- Module : Main +-- Copyright : (c) 2013-2015 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : experimental +-- Portability : non-portable (GHC extensions) + +module Main (main) where + +import Test.Tasty + +main :: IO () +main = defaultMain $ + testGroup "amazonka" + [ + ]