diff --git a/amazonka-core.cabal b/amazonka-core.cabal --- a/amazonka-core.cabal +++ b/amazonka-core.cabal @@ -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 diff --git a/src/Network/AWS/Data/Internal/Body.hs b/src/Network/AWS/Data/Internal/Body.hs --- a/src/Network/AWS/Data/Internal/Body.hs +++ b/src/Network/AWS/Data/Internal/Body.hs @@ -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)) diff --git a/src/Network/AWS/Data/Internal/Header.hs b/src/Network/AWS/Data/Internal/Header.hs --- a/src/Network/AWS/Data/Internal/Header.hs +++ b/src/Network/AWS/Data/Internal/Header.hs @@ -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" diff --git a/src/Network/AWS/Data/Internal/Time.hs b/src/Network/AWS/Data/Internal/Time.hs --- a/src/Network/AWS/Data/Internal/Time.hs +++ b/src/Network/AWS/Data/Internal/Time.hs @@ -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 diff --git a/src/Network/AWS/Data/Internal/URI.hs b/src/Network/AWS/Data/Internal/URI.hs --- a/src/Network/AWS/Data/Internal/URI.hs +++ b/src/Network/AWS/Data/Internal/URI.hs @@ -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) diff --git a/src/Network/AWS/Error.hs b/src/Network/AWS/Error.hs --- a/src/Network/AWS/Error.hs +++ b/src/Network/AWS/Error.hs @@ -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 @@ -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) diff --git a/src/Network/AWS/Prelude.hs b/src/Network/AWS/Prelude.hs --- a/src/Network/AWS/Prelude.hs +++ b/src/Network/AWS/Prelude.hs @@ -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 diff --git a/src/Network/AWS/Response.hs b/src/Network/AWS/Response.hs --- a/src/Network/AWS/Response.hs +++ b/src/Network/AWS/Response.hs @@ -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 diff --git a/src/Network/AWS/Signing/Internal.hs b/src/Network/AWS/Signing/Internal.hs --- a/src/Network/AWS/Signing/Internal.hs +++ b/src/Network/AWS/Signing/Internal.hs @@ -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 diff --git a/src/Network/AWS/Signing/Internal/V2.hs b/src/Network/AWS/Signing/Internal/V2.hs --- a/src/Network/AWS/Signing/Internal/V2.hs +++ b/src/Network/AWS/Signing/Internal/V2.hs @@ -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 diff --git a/src/Network/AWS/Signing/Internal/V3.hs b/src/Network/AWS/Signing/Internal/V3.hs --- a/src/Network/AWS/Signing/Internal/V3.hs +++ b/src/Network/AWS/Signing/Internal/V3.hs @@ -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)) diff --git a/src/Network/AWS/Signing/Internal/V4.hs b/src/Network/AWS/Signing/Internal/V4.hs --- a/src/Network/AWS/Signing/Internal/V4.hs +++ b/src/Network/AWS/Signing/Internal/V4.hs @@ -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) ] diff --git a/src/Network/AWS/Types.hs b/src/Network/AWS/Types.hs --- a/src/Network/AWS/Types.hs +++ b/src/Network/AWS/Types.hs @@ -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 diff --git a/src/Network/AWS/Waiters.hs b/src/Network/AWS/Waiters.hs new file mode 100644 --- /dev/null +++ b/src/Network/AWS/Waiters.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ViewPatterns #-} + +-- Module : Network.AWS.Waiters +-- Copyright : (c) 2013-2014 Brendan Hay +-- License : This Source Code Form is subject to the terms of +-- the Mozilla Public License, v. 2.0. +-- A copy of the MPL can be found in the LICENSE file or +-- you can obtain it at http://mozilla.org/MPL/2.0/. +-- Maintainer : Brendan Hay +-- Stability : experimental +-- Portability : non-portable (GHC extensions) + +module Network.AWS.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