amazonka-core 0.0.7.1 → 0.0.8

raw patch · 14 files changed

+305/−178 lines, 14 filesdep −old-localedep ~basedep ~bifunctorsdep ~case-insensitivePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies removed: old-locale

Dependency ranges changed: base, bifunctors, case-insensitive, lens, time

API changes (from Hackage documentation)

Files

• amazonka-core.cabal +9/−8
• src/Network/AWS/Data/Internal/Body.hs +9/−0
• src/Network/AWS/Data/Internal/Header.hs +2/−5
• src/Network/AWS/Data/Internal/Time.hs +7/−32
• src/Network/AWS/Data/Internal/URI.hs +3/−3
• src/Network/AWS/Error.hs +53/−12
• src/Network/AWS/Prelude.hs +24/−14
• src/Network/AWS/Response.hs +34/−30
• src/Network/AWS/Signing/Internal.hs +3/−6
• src/Network/AWS/Signing/Internal/V2.hs +3/−3
• src/Network/AWS/Signing/Internal/V3.hs +3/−3
• src/Network/AWS/Signing/Internal/V4.hs +32/−31
• src/Network/AWS/Types.hs +29/−31
• src/Network/AWS/Waiters.hs +94/−0

@@ -1,5 +1,5 @@ name:                  amazonka-core-version:               0.0.7.1+version:               0.0.8 synopsis:              Core functionality and data types for Amazonka libraries. homepage:              https://github.com/brendanhay/amazonka license:               OtherLicense@@ -47,6 +47,7 @@         , Network.AWS.Response         , Network.AWS.Signing         , Network.AWS.Types+        , Network.AWS.Waiters      other-modules:           Network.AWS.Data.Internal.Base64@@ -76,9 +77,9 @@         , base                 >= 4.7    && < 5         , base16-bytestring    >= 0.1    && < 1         , base64-bytestring    >= 1      && < 2-        , bifunctors           >= 0.3+        , bifunctors           >= 4.1    && < 5         , bytestring           >= 0.9-        , case-insensitive     >= 1.1+        , case-insensitive     >= 1.2    && < 2         , conduit              >= 1.1    && < 1.3         , conduit-extra        == 1.1.*         , cryptohash           == 0.11.*@@ -87,21 +88,22 @@         , hashable             >= 1.2         , http-client          >= 0.4.3  && < 0.5         , http-types           >= 0.8-        , lens                 >= 4.3    && < 5+        , lens                 >= 4.4    && < 5         , mmorph               >= 1      && < 2         , mtl                  >= 2.2.1  && < 2.3-        , nats                 >= 0.1.3  && < 1-        , old-locale           >= 1         , resourcet            == 1.1.*         , semigroups           >= 0.12         , tagged               >= 0.7         , text                 >= 1.1-        , time                 >= 1.4+        , time                 >= 1.5         , transformers         == 0.4.*         , unordered-containers >= 0.2.3         , vector               >= 0.10.9         , xml-conduit          == 1.2.* +    if !impl(ghc>=7.9)+        build-depends: nats >= 0.1.3 && < 1+ test-suite tests     type:              exitcode-stdio-1.0     default-language:  Haskell2010@@ -113,7 +115,6 @@     build-depends:           amazonka-core         , base-        , old-locale         , tasty         , tasty-hunit         , template-haskell

@@ -73,6 +73,15 @@ instance IsString RqBody where     fromString = toBody . LBS8.pack +isStreaming :: RqBody -> Bool+isStreaming b =+    case _bdyBody b of+        RequestBodyLBS           {} -> False+        RequestBodyBS            {} -> False+        RequestBodyBuilder       {} -> False+        RequestBodyStream        {} -> True+        RequestBodyStreamChunked {} -> True+ class ToBody a where     toBody :: a -> RqBody     toBody = const (RqBody (hash "") (RequestBodyLBS mempty))

@@ -19,10 +19,8 @@ import qualified Data.ByteString.Char8                as BS import qualified Data.CaseInsensitive                 as CI import           Data.Foldable                        as Fold-import           Data.Function                        (on) import           Data.HashMap.Strict                  (HashMap) import qualified Data.HashMap.Strict                  as Map-import           Data.List                            (deleteBy) import           Data.Monoid import           Data.Text                            (Text) import qualified Data.Text.Encoding                   as Text@@ -53,9 +51,8 @@ (=:) = toHeader {-# INLINE toHeaderText #-} --- FIXME: Improve complexity hdr :: HeaderName -> ByteString -> [Header] -> [Header]-hdr k v hs = let h = (k, v) in deleteBy ((==) `on` fst) h hs ++ [h]+hdr k v hs = (k, v) : filter ((/= k) . fst) hs {-# INLINE hdr #-}  hdrs :: [Header] -> [Header] -> [Header]@@ -107,7 +104,7 @@ hAMZExpires = "X-Amz-Expires"  hAMZSignedHeaders :: HeaderName-hAMZSignedHeaders = "X-Amz-Expires"+hAMZSignedHeaders = "X-Amz-SignedHeaders"  hAMZContentSHA256 :: HeaderName hAMZContentSHA256 = "X-Amz-Content-SHA256"

@@ -37,7 +37,6 @@ import           Data.Attoparsec.Text                 (Parser) import qualified Data.Attoparsec.Text                 as AText import qualified Data.ByteString.Char8                as BS-import           Data.Function                        (on) import           Data.Tagged import qualified Data.Text                            as Text import           Data.Time@@ -47,7 +46,6 @@ import           Network.AWS.Data.Internal.Query import           Network.AWS.Data.Internal.Text import           Network.AWS.Data.Internal.XML-import           System.Locale  data Format     = RFC822Format@@ -58,30 +56,17 @@       deriving (Eq, Show)  data Time :: Format -> * where-    Time       :: UTCTime    -> Time a-    LocaleTime :: TimeLocale -> UTCTime -> Time a+    Time :: UTCTime -> Time a  deriving instance Show (Time a) deriving instance Eq   (Time a)--instance Ord (Time (a :: Format)) where-    compare = compare `on` ts-      where-        ts (Time         t) = (t, defaultTimeLocale)-        ts (LocaleTime l t) = (t, l)+deriving instance Ord  (Time a) --- | This is a poorly behaved isomorphism, due to the fact 'LocaleTime' only--- exists for testing purposes, and we wish to compose using 'mapping'--- in actual usage.------ /See:/ 'convert'. _Time :: Iso' (Time a) UTCTime-_Time = iso (\case; Time a -> a; LocaleTime _ a -> a) Time+_Time = iso (\(Time t) -> t) Time --- | Safely convert between two 'Time's, unlike the '_Time' isomorphism. convert :: Time a -> Time b-convert (Time         t) = Time t-convert (LocaleTime l t) = LocaleTime l t+convert (Time t) = Time t  type RFC822    = Time RFC822Format type ISO8601   = Time ISO8601Format@@ -115,7 +100,7 @@ parseFormattedTime :: forall a. TimeFormat (Time a) => Parser (Time a) parseFormattedTime = do     x <- Text.unpack <$> AText.takeText-    p (parseTime defaultTimeLocale (untag f) x) x+    p (parseTimeM True defaultTimeLocale (untag f) x) x   where     p :: Maybe UTCTime -> String -> Parser (Time a)     p Nothing  s = fail   ("Unable to parse " ++ untag f ++ " from " ++ s)@@ -130,21 +115,11 @@ instance ToText AWSTime   where toText = Text.pack . renderFormattedTime  instance ToText POSIX where-    toText t = toText time-      where-        time :: Integer-        time = truncate . utcTimeToPOSIXSeconds $-            case t of-                Time         x -> x-                LocaleTime _ x -> x+    toText (Time t) = toText (truncate (utcTimeToPOSIXSeconds t) :: Integer)  renderFormattedTime :: forall a. TimeFormat (Time a) => Time a -> String-renderFormattedTime x = formatTime l (untag f) t+renderFormattedTime (Time t) = formatTime defaultTimeLocale (untag f) t   where-    (l, t) = case x of-        Time          t' -> (defaultTimeLocale, t')-        LocaleTime l' t' -> (l', t')-     f :: Tagged (Time a) String     f = format 

@@ -11,7 +11,7 @@ -- Portability : non-portable (GHC extensions)  module Network.AWS.Data.Internal.URI-    ( collapseURI+    ( collapsePath     ) where  import           Data.ByteString.Char8 (ByteString)@@ -19,8 +19,8 @@ import qualified Data.Foldable         as Fold import           Data.Monoid -collapseURI :: ByteString -> ByteString-collapseURI bs+collapsePath :: ByteString -> ByteString+collapsePath bs     | BS.null bs   = slash     | BS.null path = slash     | otherwise    = tl (hd path)

@@ -1,11 +1,12 @@-{-# LANGUAGE DeriveGeneric     #-}-{-# LANGUAGE FlexibleContexts  #-}-{-# LANGUAGE LambdaCase        #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards   #-}-{-# LANGUAGE TemplateHaskell   #-}-{-# LANGUAGE TypeFamilies      #-}-{-# LANGUAGE ViewPatterns      #-}+{-# LANGUAGE DeriveGeneric              #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase                 #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE RecordWildCards            #-}+{-# LANGUAGE TemplateHaskell            #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE ViewPatterns               #-}  -- Module      : Network.AWS.Error -- Copyright   : (c) 2013-2014 Brendan Hay <brendan.g.hay@gmail.com>@@ -22,8 +23,16 @@     -- * Status Checks       statusSuccess +    -- * Classes+    , AWSError     (..)+    , AWSErrorCode (..)++    -- * Types+    , ErrorCode    (..)+    , ErrorType    (..)+    , ServiceError (..)+     -- * REST Errors-    , ErrorType (..)     , RESTError     , restRequestId     , restType@@ -34,6 +43,7 @@     -- * JSON Errors     , JSONError     , jsonType+    , jsonCode     , jsonMessage     , jsonError     ) where@@ -43,6 +53,7 @@ import           Data.Aeson import qualified Data.ByteString.Lazy       as LBS import           Data.ByteString.Lazy.Char8 (unpack)+import           Data.String import           Data.Text                  (Text) import           GHC.Generics import           Network.AWS.Data@@ -52,6 +63,22 @@ statusSuccess :: Status -> Bool statusSuccess (statusCode -> n) = n >= 200 && n < 400 +class AWSError a where+    awsError :: a -> ServiceError String++instance Show a => AWSError (ServiceError a) where+    awsError = \case+        HttpError       e     -> HttpError e+        SerializerError a e   -> SerializerError a e+        ServiceError    a s x -> ServiceError a s (show x)+        Errors          xs    -> Errors (map awsError xs)++newtype ErrorCode = ErrorCode Text+    deriving (Eq, Ord, Show, FromXML, FromJSON, IsString, Generic)++class AWSErrorCode a where+    awsErrorCode :: a -> ErrorCode+ data ErrorType     = Receiver     | Sender@@ -69,12 +96,15 @@ data RESTError = RESTError     { _restRequestId :: Text     , _restType      :: Maybe ErrorType-    , _restCode      :: Text+    , _restCode      :: ErrorCode     , _restMessage   :: Text     } deriving (Eq, Show, Generic)  makeLenses ''RESTError +instance AWSErrorCode RESTError where+    awsErrorCode = _restCode+ instance FromXML RESTError where     parseXML x = withElement "Error" f x <|> f x       where@@ -100,16 +130,27 @@  data JSONError = JSONError     { _jsonType    :: Maybe Text+    , _jsonCode    :: ErrorCode     , _jsonMessage :: Text     } deriving (Eq, Show, Generic)  makeLenses ''JSONError +instance AWSErrorCode JSONError where+    awsErrorCode = _jsonCode+ instance FromJSON JSONError where     parseJSON = withObject "JSONError" $ \o -> rest o <|> post o       where-        rest o = JSONError <$> o .:? "Type"   <*> o .: "Message"-        post o = JSONError <$> o .:? "__type" <*> o .: "message"+        rest o = JSONError+             <$> o .:? "Type"+             <*> o .:  "Code"+             <*> o .:  "Message"++        post o = JSONError+             <$> o .:? "__type"+             <*> o .:  "code"+             <*> o .:  "message"  jsonError :: FromJSON (Er a)           => (Status -> Bool)

@@ -24,47 +24,57 @@     , HashMap     , HttpException     , Natural-    , NonEmpty+    , NonEmpty     (..)     , RequestBody     , Response     , Text      -- * Classes-    , AWSError        (..)-    , AWSPager        (..)-    , AWSRequest      (..)-    , AWSService      (..)+    , AWSPager     (..)+    , AWSRequest   (..)+    , AWSService   (..)     , Generic-    , IsString        (..)+    , IsString     (..)     , Semigroup     , Whole -    -- * Shared-    , Empty           (..)-    , Service         (..)+    -- * Retries+    , Retry        (..)      -- * Errors-    , ServiceError    (..)+    , AWSError     (..)+    , AWSErrorCode (..)+    , ServiceError (..)+    , RESTError+    , restError+    , JSONError+    , jsonError+    , statusSuccess +    -- * Shared+    , Empty        (..)+    , Service      (..)+     -- * HTTP-    , StdMethod (..)-    , Status+    , StdMethod    (..)+    , Status       (..)     ) where +import Network.AWS.Error import Network.AWS.Types  import Control.Exception         (Exception) import Data.ByteString           (ByteString) import Data.CaseInsensitive      (CI) import Data.HashMap.Strict       (HashMap)-import Data.List.NonEmpty        (NonEmpty)+import Data.List.NonEmpty        (NonEmpty(..)) import Data.Semigroup            (Semigroup) import Data.String               (IsString(..)) import Data.Text                 (Text) import GHC.Generics              (Generic) import Network.HTTP.Client       (HttpException, RequestBody) import Network.HTTP.Types.Method (StdMethod(..))-import Network.HTTP.Types.Status (Status)+import Network.HTTP.Types.Status (Status(..)) import Numeric.Natural           (Natural, Whole)  import Control.Applicative       as Export

@@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleContexts    #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections       #-} {-# LANGUAGE TypeFamilies        #-}  -- Module      : Network.AWS.Response@@ -34,62 +35,62 @@ import qualified Data.Conduit.Binary          as Conduit import           Network.AWS.Data             (LazyByteString, FromXML(..), decodeXML) import           Network.AWS.Types-import           Network.HTTP.Client          hiding (Response)+import           Network.HTTP.Client          hiding (Request, Response) import           Network.HTTP.Types import           Text.XML                     (Node)  nullResponse :: (MonadResource m, AWSService (Sv a))-                => Rs a-                -> a-                -> Either HttpException ClientResponse-                -> m (Response a)+             => Rs a+             -> Request a+             -> Either HttpException ClientResponse+             -> m (Response' a) nullResponse rs = receive $ \_ _ bdy ->     liftResourceT (bdy $$+- return (Right rs)) {-# INLINE nullResponse #-}  headerResponse :: (MonadResource m, AWSService (Sv a))                => (ResponseHeaders -> Either String (Rs a))-               -> a+               -> Request a                -> Either HttpException ClientResponse-               -> m (Response a)+               -> m (Response' a) headerResponse f = deserialise (const (Right ())) (const . f) {-# INLINE headerResponse #-}  xmlResponse :: (MonadResource m, AWSService (Sv a), FromXML (Rs a))-            => a+            => Request a             -> Either HttpException ClientResponse-            -> m (Response a)+            -> m (Response' a) xmlResponse = deserialise (decodeXML >=> parseXML) (const Right) {-# INLINE xmlResponse #-}  xmlHeaderResponse :: (MonadResource m, AWSService (Sv a))                   => (ResponseHeaders -> [Node] -> Either String (Rs a))-                  -> a+                  -> Request a                   -> Either HttpException ClientResponse-                  -> m (Response a)+                  -> m (Response' a) xmlHeaderResponse = deserialise decodeXML {-# INLINE xmlHeaderResponse #-}  jsonResponse :: (MonadResource m, AWSService (Sv a), FromJSON (Rs a))-             => a+             => Request a              -> Either HttpException ClientResponse-             -> m (Response a)+             -> m (Response' a) jsonResponse = deserialise eitherDecode' (const Right) {-# INLINE jsonResponse #-}  jsonHeaderResponse :: (MonadResource m, AWSService (Sv a))                    => (ResponseHeaders -> Object -> Either String (Rs a))-                   -> a+                   -> Request a                    -> Either HttpException ClientResponse-                   -> m (Response a)+                   -> m (Response' a) jsonHeaderResponse = deserialise eitherDecode' {-# INLINE jsonHeaderResponse #-}  bodyResponse :: (MonadResource m, AWSService (Sv a))              => (ResponseHeaders -> ResponseBody -> Either String (Rs a))-             -> a+             -> Request a              -> Either HttpException ClientResponse-             -> m (Response a)+             -> m (Response' a) bodyResponse f = receive $ \a hs bdy ->     return (SerializerError a `first` f hs bdy) {-# INLINE bodyResponse #-}@@ -97,9 +98,9 @@ deserialise :: (AWSService (Sv a), MonadResource m)             => (LazyByteString -> Either String b)             -> (ResponseHeaders -> b -> Either String (Rs a))-            -> a+            -> Request a             -> Either HttpException ClientResponse-            -> m (Response a)+            -> m (Response' a) deserialise g f = receive $ \a hs bdy -> do     lbs <- sinkLbs bdy     return $! case g lbs of@@ -112,21 +113,24 @@  receive :: forall m a. (MonadResource m, AWSService (Sv a))         => (Abbrev -> ResponseHeaders -> ResponseBody -> m (Response a))-        -> a+        -> Request a         -> Either HttpException ClientResponse-        -> m (Response a)+        -> m (Response' a) receive f = const (either (return . Left . HttpError) success)   where-    success rs =-        maybe (f (_svcAbbrev svc) hs bdy)-              (\g -> Left . g <$> sinkLbs bdy)-              (handle svc s)-      where-        svc = service :: Service (Sv a)+    success rs = do+        let s   = responseStatus  rs+            bdy = responseBody    rs+            hs  = responseHeaders rs+        case _svcHandle svc s of+            Just g  -> Left . g <$> sinkLbs bdy+            Nothing -> do+                x <- f (_svcAbbrev svc) hs bdy+                case x of+                    Left  e -> return (Left e)+                    Right y -> return $! Right (s, y) -        s   = responseStatus  rs-        bdy = responseBody    rs-        hs  = responseHeaders rs+    svc = service :: Service (Sv a) {-# INLINE receive #-}  sinkLbs :: MonadResource m => ResponseBody -> m LBS.ByteString

@@ -21,7 +21,6 @@ import           Data.ByteString        (ByteString) import           Data.Time import           Network.AWS.Types-import           System.Locale  sign :: (MonadIO m, AWSRequest a, AWSSigner (Sg (Sv a)))      => Auth      -- ^ AWS authentication credentials.@@ -29,18 +28,16 @@      -> Request a -- ^ Request to sign.      -> UTCTime   -- ^ Signing time.      -> m (Signed a (Sg (Sv a)))-sign a r rq t = withAuth a $ \e -> return $-    signed e r rq defaultTimeLocale t+sign a r rq t = withAuth a $ \e -> return (signed e r rq t)  presign :: (MonadIO m, AWSRequest a, AWSPresigner (Sg (Sv a)))         => Auth      -- ^ AWS authentication credentials.         -> Region    -- ^ AWS Region.         -> Request a -- ^ Request to presign.         -> UTCTime   -- ^ Signing time.-        -> UTCTime   -- ^ Expiry time.+        -> Integer   -- ^ Expiry time in seconds.         -> m (Signed a (Sg (Sv a)))-presign a r rq t x = withAuth a $ \e -> return $-    presigned e r rq defaultTimeLocale t x+presign a r rq t ex = withAuth a $ \e -> return (presigned e r rq t ex)  hmacSHA256 :: ByteString -> ByteString -> ByteString hmacSHA256 = HMAC.hmac SHA256.hash 64

@@ -48,7 +48,7 @@         ]  instance AWSSigner V2 where-    signed AuthEnv{..} r x@Request{..} l t = Signed meta rq+    signed AuthEnv{..} r x@Request{..} t = Signed meta rq       where         meta = Meta             { _mSignature = signature@@ -80,7 +80,7 @@          query =              pair "Version"          (_svcVersion svc)-           . pair "SignatureVersion" ("2" :: ByteString)+           . pair "SignatureVersion" ("2"          :: ByteString)            . pair "SignatureMethod"  ("HmacSHA256" :: ByteString)            . pair "Timestamp"        time            . pair "AWSAccessKeyId"   (toBS _authAccess)@@ -90,6 +90,6 @@          headers = hdr hDate time _rqHeaders -        time = toBS (LocaleTime l t :: ISO8601)+        time = toBS (Time t :: ISO8601)          svc = serviceOf x

@@ -49,7 +49,7 @@         ]  instance AWSSigner V3 where-    signed AuthEnv{..} r x@Request{..} l t = Signed meta rq+    signed AuthEnv{..} r x@Request{..} t = Signed meta rq       where         meta = Meta             { _mSignature = signature@@ -69,7 +69,7 @@         headers = sortBy (comparing fst)             . hdr hAMZAuth authorisation             . hdr hHost _endpointHost-            . hdr hDate (toBS (LocaleTime l t :: RFC822))+            . hdr hDate (toBS (Time t :: RFC822))             $ _rqHeaders                 ++ maybeToList ((hAMZToken,) . toBS <$> _authToken) @@ -79,4 +79,4 @@             <> signature          signature = Base64.encode-            $ hmacSHA256 (toBS _authSecret) (toBS (LocaleTime l t :: AWSTime))+            $ hmacSHA256 (toBS _authSecret) (toBS (Time t :: AWSTime))

@@ -37,7 +37,6 @@ import           Network.AWS.Signing.Internal import           Network.AWS.Types import           Network.HTTP.Types.Header-import           System.Locale  data V4 @@ -67,33 +66,37 @@         ]  instance AWSPresigner V4 where-    presigned a r rq l t x = out-        & sgRequest . queryString <>~ auth (out ^. sgMeta)+    presigned a r rq t ex = out & sgRequest+        . queryString <>~ auth (out ^. sgMeta)       where-        out = finalise Nothing qry service a r rq l t+        out = finalise qry hash r service a inp t          qry cs sh =               pair (CI.original hAMZAlgorithm)     algorithm             . pair (CI.original hAMZCredential)    cs-            . pair (CI.original hAMZDate)          (LocaleTime l t :: ISO8601)-            . pair (CI.original hAMZExpires)       (LocaleTime l x :: ISO8601)+            . pair (CI.original hAMZDate)          (Time t :: AWSTime)+            . pair (CI.original hAMZExpires)       ex             . pair (CI.original hAMZSignedHeaders) sh             . pair (CI.original hAMZToken)         (toBS <$> _authToken a)-            . pair (CI.original hAMZContentSHA256) ("UNSIGNED-PAYLOAD" :: ByteString) -        auth = mappend "&X-AMZ-Signature=" . _mSignature+        inp = rq & rqHeaders .~ [] +        auth = mappend "&X-Amz-Signature=" . _mSignature++        hash = "UNSIGNED-PAYLOAD"+ instance AWSSigner V4 where-    signed a r rq l t = out-        & sgRequest+    signed a r rq t = out & sgRequest         %~ requestHeaders         %~ hdr hAuthorization (authorisation $ out ^. sgMeta)       where-        out = finalise (Just "AWS4") (\_ _ -> id) service a r inp l t+        out = finalise (\_ _ -> id) hash r service a inp t -        inp = rq & rqHeaders %~ hdrs (maybeToList tok)+        inp = rq & rqHeaders %~ hdr hAMZDate date . hdrs (maybeToList tok) -        tok = (hAMZToken,) . toBS <$> _authToken a+        date = toBS (Time t :: AWSTime)+        tok  = (hAMZToken,) . toBS <$> _authToken a+        hash = bodyHash (_rqBody rq)  authorisation :: Meta V4 -> ByteString authorisation Meta{..} = BS.concat@@ -109,21 +112,21 @@ algorithm :: ByteString algorithm = "AWS4-HMAC-SHA256" -finalise :: Maybe ByteString-         -> (ByteString -> ByteString -> Query -> Query)+finalise :: (ByteString -> ByteString -> Query -> Query)+         -> ByteString+         -> Region          -> Service (Sv a)          -> AuthEnv-         -> Region          -> Request a-         -> TimeLocale          -> UTCTime          -> Signed a V4-finalise p qry s@Service{..} AuthEnv{..} r Request{..} l t = Signed meta rq+finalise qry hash r s@Service{..} AuthEnv{..} Request{..} t =+    Signed meta rq   where     meta = Meta         { _mAlgorithm = algorithm         , _mCReq      = canonicalRequest-        , _mScope     = toBS _authAccess <> "/" <> credentialScope+        , _mScope     = accessScope         , _mSigned    = signedHeaders         , _mSTS       = stringToSign         , _mSignature = signature@@ -134,21 +137,18 @@         & method         .~ meth         & host           .~ _endpointHost         & path           .~ _rqPath-        & queryString    .~ toBS query+        & queryString    .~ BS.cons '?' (toBS query)         & requestHeaders .~ headers         & requestBody    .~ _bdyBody _rqBody      meth  = toBS _rqMethod-    query = qry credentialScope signedHeaders _rqQuery+    query = qry accessScope signedHeaders _rqQuery      Endpoint{..} = endpoint s r      canonicalQuery = toBS (query & valuesOf %~ Just . fromMaybe "") -    headers = sortBy (comparing fst)-        . hdr hHost _endpointHost-        . hdr hAMZDate (toBS (LocaleTime l t :: AWSTime))-        $ _rqHeaders+    headers = sortBy (comparing fst) (hdr hHost _endpointHost _rqHeaders)      joinedHeaders = map f $ groupBy ((==) `on` fst) headers       where@@ -171,15 +171,15 @@      canonicalRequest = mconcat $ intersperse "\n"        [ meth-       , collapseURI _rqPath+       , collapsePath _rqPath        , canonicalQuery        , canonicalHeaders        , signedHeaders-       , bodyHash _rqBody+       , hash        ]      scope =-        [ toBS (LocaleTime l t :: BasicTime)+        [ toBS (Time t :: BasicTime)         , toBS _endpointScope         , toBS _svcPrefix         , "aws4_request"@@ -187,12 +187,13 @@      credentialScope = BS.intercalate "/" scope -    signingKey = Fold.foldl1 hmacSHA256 $-        maybe (toBS _authSecret) (<> toBS _authSecret) p : scope+    accessScope = toBS _authAccess <> "/" <> credentialScope +    signingKey = Fold.foldl1 hmacSHA256 $ ("AWS4" <> toBS _authSecret) : scope+     stringToSign = BS.intercalate "\n"         [ algorithm-        , toBS (LocaleTime l t :: AWSTime)+        , toBS (Time t :: AWSTime)         , credentialScope         , Base16.encode (SHA256.hash canonicalRequest)         ]

@@ -1,3 +1,4 @@+{-# LANGUAGE BangPatterns               #-} {-# LANGUAGE DefaultSignatures          #-} {-# LANGUAGE DeriveDataTypeable         #-} {-# LANGUAGE DeriveGeneric              #-}@@ -36,11 +37,14 @@     , withAuth      -- * Services-    , Abbrev     , AWSService    (..)+    , Abbrev     , Service       (..)     , serviceOf +    -- * Retries+    , Retry         (..)+     -- * Endpoints     , Endpoint      (..)     , endpoint@@ -52,9 +56,6 @@     , _ServiceError     , _Errors -    , AWSError-    , awsError-     -- * Signing     , AWSSigner     (..)     , AWSPresigner  (..)@@ -75,6 +76,7 @@      -- * Responses     , Response+    , Response'     , Empty         (..)      -- * Regions@@ -119,7 +121,6 @@ import           Network.HTTP.Types.Header import           Network.HTTP.Types.Method import           Network.HTTP.Types.Status    (Status)-import           System.Locale  -- | Abbreviated service name. type Abbrev = Text@@ -127,10 +128,10 @@ -- | An error type representing the subset of errors that can be directly -- attributed to this library. data ServiceError a-    = HttpError       HttpException-    | SerializerError Abbrev String-    | ServiceError    Abbrev Status a-    | Errors          [ServiceError a]+    = HttpError        HttpException+    | SerializerError  Abbrev String+    | ServiceError     Abbrev Status a+    | Errors           [ServiceError a]       deriving (Show, Typeable)  instance (Show a, Typeable a) => Exception (ServiceError a)@@ -142,16 +143,6 @@         f (Errors xs) = xs         f x           = [x] -class AWSError a where-    awsError :: a -> ServiceError String--instance Show a => AWSError (ServiceError a) where-    awsError = \case-        HttpError       e     -> HttpError e-        SerializerError a e   -> SerializerError a e-        ServiceError    a s x -> ServiceError a s (show x)-        Errors          xs    -> Errors (map awsError xs)- -- | The properties (such as endpoint) for a service, as well as it's -- associated signing algorithm and error types. class (AWSSigner (Sg a), Show (Er a)) => AWSService a where@@ -162,17 +153,16 @@     type Er a :: *      service :: Service a-    handle  :: Service a-            -> Status-            -> Maybe (LazyByteString -> ServiceError (Er a))  serviceOf :: AWSService (Sv a) => Request a -> Service (Sv a) serviceOf = const service  -- | An alias for the common response 'Either' containing a service error in the -- 'Left' case, or the expected response in the 'Right'.-type Response a = Either (ServiceError (Er (Sv a))) (Rs a)+type Response  a = Either (ServiceError (Er (Sv a))) (Rs a) +type Response' a = Either (ServiceError (Er (Sv a))) (Status, Rs a)+ -- | Specify how a request can be de/serialised. class (AWSService (Sv a), AWSSigner (Sg (Sv a))) => AWSRequest a where     -- | The service definition for a request.@@ -183,9 +173,9 @@      request  :: a -> Request a     response :: MonadResource m-             => a+             => Request a              -> Either HttpException ClientResponse-             -> m (Response a)+             -> m (Response' a)  -- | Specify how an 'AWSRequest' and it's associated 'Rs' response can generate -- a subsequent request, if available.@@ -217,7 +207,6 @@            => AuthEnv            -> Region            -> Request a-           -> TimeLocale            -> UTCTime            -> Signed a v @@ -226,9 +215,8 @@               => AuthEnv               -> Region               -> Request a-              -> TimeLocale               -> UTCTime-              -> UTCTime+              -> Integer               -> Signed a v  -- | Access key credential.@@ -365,16 +353,26 @@ -- | Attributes specific to an AWS service. data Service a = Service     { _svcAbbrev       :: !Text-    , _svcPrefix       :: ByteString-    , _svcVersion      :: ByteString+    , _svcPrefix       :: !ByteString+    , _svcVersion      :: !ByteString     , _svcTargetPrefix :: Maybe ByteString     , _svcJSONVersion  :: Maybe ByteString+    , _svcHandle       :: Status -> Maybe (LazyByteString -> ServiceError (Er a))+    , _svcRetry        :: Retry a     } +-- | Constants and predicates used to create a 'RetryPolicy'.+data Retry a = Exponential+    { _retryBase     :: !Double+    , _retryGrowth   :: !Int+    , _retryAttempts :: !Int+    , _retryCheck    :: Status -> Er a -> Bool+    }+ -- | An unsigned request. data Request a = Request     { _rqMethod  :: !StdMethod-    , _rqPath    :: ByteString+    , _rqPath    :: !ByteString     , _rqQuery   :: Query     , _rqHeaders :: [Header]     , _rqBody    :: RqBody

@@ -0,0 +1,94 @@+{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE LambdaCase        #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes        #-}+{-# LANGUAGE ViewPatterns      #-}++-- Module      : Network.AWS.Waiters+-- Copyright   : (c) 2013-2014 Brendan Hay <brendan.g.hay@gmail.com>+-- License     : This Source Code Form is subject to the terms of+--               the Mozilla Public License, v. 2.0.+--               A copy of the MPL can be found in the LICENSE file or+--               you can obtain it at http://mozilla.org/MPL/2.0/.+-- Maintainer  : Brendan Hay <brendan.g.hay@gmail.com>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)++module Network.AWS.Waiters+    (+    -- * Types+      Acceptor+    , Accept (..)+    , Wait   (..)++    -- * Acceptors+    , accept++    -- * Matchers+    , matchAll+    , matchAny+    , matchError+    , matchStatus++    -- * Lenses+    , module Control.Lens+    ) where++import Control.Lens+import Data.ByteString    (ByteString)+import Data.Maybe+import Network.AWS.Data+import Network.AWS.Error+import Network.AWS.Types+import Network.HTTP.Types++type Acceptor a = Request a -> Response' a -> Maybe Accept++data Accept+    = AcceptSuccess+    | AcceptFailure+    | AcceptRetry+      deriving (Eq, Show)++instance ToBuilder Accept where+    build = \case+        AcceptSuccess -> "Success"+        AcceptFailure -> "Failure"+        AcceptRetry   -> "Retry"++-- | Timing and acceptance criteria to check fulfillment of a remote operation.+data Wait a = Wait+    { _waitName      :: !ByteString+    , _waitAttempts  :: !Int+    , _waitDelay     :: !Int+    , _waitAcceptors :: [Acceptor a]+    }++accept :: Wait a -> Acceptor a+accept w rq rs = listToMaybe . mapMaybe (\f -> f rq rs) $ _waitAcceptors w++matchAll :: Eq b => b -> Accept -> Fold (Rs a) b -> Acceptor a+matchAll x a l = match (allOf l (== x)) a++matchAny :: Eq b => b -> Accept -> Fold (Rs a) b -> Acceptor a+matchAny x a l = match (anyOf l (== x)) a++matchStatus :: Int -> Accept -> Acceptor a+matchStatus x a _ = \case+    Left (ServiceError _ s _)+        | x == statusCode s -> Just a+    Right (s, _)+        | x == statusCode s -> Just a+    _                       -> Nothing++matchError :: AWSErrorCode (Er (Sv a)) => ErrorCode -> Accept -> Acceptor a+matchError c a _ = \case+    Left (ServiceError _ _ e)+        | c == awsErrorCode e -> Just a+    _                         -> Nothing++match :: (Rs a -> Bool) -> Accept -> Acceptor a+match f a _ = \case+    Right (_, rs)+        | f rs -> Just a+    _          -> Nothing