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.1 +version: 0.0.2 synopsis: Core functionality, serialisation primitives, and data types for the Amazonka Amazon Web Services SDKs. homepage: https://github.com/brendanhay/amazonka license: OtherLicense @@ -40,6 +40,7 @@ , Network.AWS.Request.Query , Network.AWS.Request.RestJSON , Network.AWS.Request.RestXML + , Network.AWS.Request.S3 , Network.AWS.Response , Network.AWS.Signing.Internal , Network.AWS.Signing.V2 @@ -82,7 +83,7 @@ , hashable >= 1.2 , http-client >= 0.3.6 && < 0.4 , http-types >= 0.8 - , lens >= 4.4 && < 5 + , lens >= 4.3 && < 5 , mmorph >= 1 && < 2 , mtl >= 2.2.1 && < 2.3 , nats >= 0.1.3 diff --git a/src/Network/AWS/Auth.hs b/src/Network/AWS/Auth.hs --- a/src/Network/AWS/Auth.hs +++ b/src/Network/AWS/Auth.hs @@ -108,7 +108,7 @@ 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)) + Discover -> fromEnv `catchError` const (iam `catchError` const err) where iam = show `withExceptT` fromProfile m err = throwError "Unable to read environment variables or IAM profile." diff --git a/src/Network/AWS/Data/Internal/Base64.hs b/src/Network/AWS/Data/Internal/Base64.hs --- a/src/Network/AWS/Data/Internal/Base64.hs +++ b/src/Network/AWS/Data/Internal/Base64.hs @@ -1,6 +1,5 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -- Module : Network.AWS.Data.Internal.Base64 -- Copyright : (c) 2013-2014 Brendan Hay 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 @@ -56,6 +56,9 @@ makeLenses ''RqBody +bodyHash :: RqBody -> ByteString +bodyHash = digestToHexByteString . _bdyHash + instance ToText RqBody where toText (RqBody h _) = "RqBody " <> toText h <> " " diff --git a/src/Network/AWS/Data/Internal/ByteString.hs b/src/Network/AWS/Data/Internal/ByteString.hs --- a/src/Network/AWS/Data/Internal/ByteString.hs +++ b/src/Network/AWS/Data/Internal/ByteString.hs @@ -1,7 +1,5 @@ -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleInstances #-} -- Copyright : (c) 2013-2014 Brendan Hay -- License : This Source Code Form is subject to the terms of @@ -25,7 +23,6 @@ ) where import Crypto.Hash -import Data.Aeson import Data.ByteString (ByteString) import qualified Data.ByteString.Base64 as Base64 import Data.ByteString.Builder (Builder) @@ -39,7 +36,6 @@ import Data.Text (Text) import qualified Data.Text.Encoding as Text import Data.Time (UTCTime) -import GHC.Generics import Network.AWS.Data.Internal.Text import Network.HTTP.Types.Method import Numeric.Natural 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 @@ -30,24 +30,6 @@ import Network.AWS.Data.Internal.Text import Network.HTTP.Types -hHost :: HeaderName -hHost = "Host" - -hAMZToken :: HeaderName -hAMZToken = "X-Amz-Security-Token" - -hAMZTarget :: HeaderName -hAMZTarget = "X-Amz-Target" - -hAMZAuth :: HeaderName -hAMZAuth = "X-Amzn-Authorization" - -hAMZDate :: HeaderName -hAMZDate = "X-Amz-Date" - -hMetaPrefix :: HeaderName -hMetaPrefix = "X-Amz-" - (~:) :: FromText a => ResponseHeaders -> HeaderName -> Either String a hs ~: k = hs ~:? k >>= note where @@ -105,3 +87,36 @@ instance (ToByteString k, ToByteString v) => ToHeader (HashMap k v) where toHeader p = map (\(k, v) -> (p <> CI.mk (toBS k), toBS v)) . Map.toList {-# INLINE toHeader #-} + +hHost :: HeaderName +hHost = "Host" + +hAMZToken :: HeaderName +hAMZToken = "X-Amz-Security-Token" + +hAMZTarget :: HeaderName +hAMZTarget = "X-Amz-Target" + +hAMZAlgorithm :: HeaderName +hAMZAlgorithm = "X-Amz-Algorithm" + +hAMZCredential :: HeaderName +hAMZCredential = "X-Amz-Credential" + +hAMZExpires :: HeaderName +hAMZExpires = "X-Amz-Expires" + +hAMZSignedHeaders :: HeaderName +hAMZSignedHeaders = "X-Amz-Expires" + +hAMZContentSHA256 :: HeaderName +hAMZContentSHA256 = "X-Amz-Content-SHA256" + +hAMZAuth :: HeaderName +hAMZAuth = "X-Amzn-Authorization" + +hAMZDate :: HeaderName +hAMZDate = "X-Amz-Date" + +hMetaPrefix :: HeaderName +hMetaPrefix = "X-Amz-" diff --git a/src/Network/AWS/Data/Internal/JSON.hs b/src/Network/AWS/Data/Internal/JSON.hs --- a/src/Network/AWS/Data/Internal/JSON.hs +++ b/src/Network/AWS/Data/Internal/JSON.hs @@ -31,7 +31,6 @@ ) where import Data.Aeson.Types -import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as Map import Data.Text (Text) import Network.AWS.Data.Internal.Text diff --git a/src/Network/AWS/Data/Internal/List.hs b/src/Network/AWS/Data/Internal/List.hs --- a/src/Network/AWS/Data/Internal/List.hs +++ b/src/Network/AWS/Data/Internal/List.hs @@ -23,6 +23,8 @@ module Network.AWS.Data.Internal.List where +import Debug.Trace + import Control.Lens hiding (coerce, element) import Control.Monad import Data.Aeson diff --git a/src/Network/AWS/Data/Internal/Map.hs b/src/Network/AWS/Data/Internal/Map.hs --- a/src/Network/AWS/Data/Internal/Map.hs +++ b/src/Network/AWS/Data/Internal/Map.hs @@ -141,7 +141,7 @@ , FromXML k , FromXML v ) => FromXML (EMap e i j k v) where - parseXML = fmap fromList . traverse (withElement e go . (:[])) + parseXML = fmap fromList . traverse go . mapMaybe (childNodes e) where go ns | length ns == 2 = diff --git a/src/Network/AWS/Data/Internal/Text.hs b/src/Network/AWS/Data/Internal/Text.hs --- a/src/Network/AWS/Data/Internal/Text.hs +++ b/src/Network/AWS/Data/Internal/Text.hs @@ -15,9 +15,8 @@ module Network.AWS.Data.Internal.Text ( FromText (..) , fromText - , match - , matchCI , AText.takeText + , matchCI , ToText (..) , showText @@ -47,11 +46,6 @@ fromText :: FromText a => Text -> Either String a fromText = AText.parseOnly parser {-# INLINE fromText #-} - --- FIXME: improve the error messages for partial match, or extra input etc. -match :: Text -> a -> Parser a -match x y = AText.string x <* AText.endOfInput >> return y -{-# INLINE match #-} matchCI :: Text -> a -> Parser a matchCI x y = AText.asciiCI x <* AText.endOfInput >> return y 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 @@ -87,7 +87,7 @@ format :: Tagged a String instance TimeFormat RFC822 where format = Tagged "%a, %d %b %Y %H:%M:%S GMT" -instance TimeFormat ISO8601 where format = Tagged (iso8601DateFormat (Just "%XZ")) +instance TimeFormat ISO8601 where format = Tagged (iso8601DateFormat (Just "%X%QZ")) instance TimeFormat BasicTime where format = Tagged "%Y%m%d" instance TimeFormat AWSTime where format = Tagged "%Y%m%dT%H%M%SZ" diff --git a/src/Network/AWS/Data/Internal/XML.hs b/src/Network/AWS/Data/Internal/XML.hs --- a/src/Network/AWS/Data/Internal/XML.hs +++ b/src/Network/AWS/Data/Internal/XML.hs @@ -1,7 +1,6 @@ {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} -- Module : Network.AWS.Data.Internal.XML @@ -143,10 +142,7 @@ err = Left $ "unable to find element " ++ show n ++ " in nodes " - ++ show (mapMaybe name ns) - - name (NodeElement e) = Just (nameLocalName (elementName e)) - name _ = Nothing + ++ show (mapMaybe localName ns) {-# INLINE findElement #-} childNodes :: Text -> Node -> Maybe [Node] @@ -154,6 +150,11 @@ | nameLocalName (elementName e) == n = Just (elementNodes e) childNodes _ _ = Nothing {-# INLINE childNodes #-} + +localName :: Node -> Maybe Text +localName (NodeElement e) = Just (nameLocalName (elementName e)) +localName _ = Nothing +{-# INLINE localName #-} class FromXML a where parseXML :: [Node] -> Either String a 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,5 +1,6 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} @@ -16,11 +17,29 @@ -- Stability : experimental -- Portability : non-portable (GHC extensions) -module Network.AWS.Error where +module Network.AWS.Error + ( + -- * Status Checks + statusSuccess + -- * REST Errors + , ErrorType (..) + , RESTError + , restRequestId + , restType + , restCode + , restMessage + , restError + + -- * JSON Errors + , JSONError + , jsonType + , jsonMessage + , jsonError + ) where + import Control.Applicative import Control.Lens -import Control.Monad import Data.Aeson import qualified Data.ByteString.Lazy as LBS import Data.ByteString.Lazy.Char8 (unpack) @@ -39,37 +58,31 @@ deriving (Eq, Ord, Enum, Show, Generic) instance FromText ErrorType where - parser = match "Receiver" Receiver - <|> match "Sender" Sender + parser = takeText >>= \case + "Receiver" -> pure Receiver + "Sender" -> pure Sender + e -> fail $ "Failure parsing ErrorType from " ++ show e instance FromXML ErrorType where parseXML = parseXMLText "Type" -data RESTMessage = RESTMessage - { _msgType :: !ErrorType - , _msgCode :: Text - , _msgRESTMessage :: Text - } deriving (Eq, Ord, Show, Generic) - -makeLenses ''RESTMessage - -instance FromXML RESTMessage where - parseXML x = RESTMessage - <$> x .@ "Type" - <*> x .@ "Code" - <*> x .@ "Message" - data RESTError = RESTError - { _errError :: RESTMessage - , _errRequestId :: Text + { _restRequestId :: Text + , _restType :: Maybe ErrorType + , _restCode :: Text + , _restMessage :: Text } deriving (Eq, Show, Generic) makeLenses ''RESTError instance FromXML RESTError where - parseXML x = RESTError - <$> x .@ "Error" - <*> x .@ "RequestId" + parseXML x = withElement "Error" f x <|> f x + where + f y = RESTError + <$> x .@ "RequestId" + <*> y .@? "Type" + <*> y .@ "Code" + <*> y .@ "Message" restError :: FromXML (Er a) => (Status -> Bool) @@ -86,16 +99,17 @@ success = ServiceError _svcAbbrev s data JSONError = JSONError - { _errType :: Maybe Text - , _errMessage :: Text + { _jsonType :: Maybe Text + , _jsonMessage :: Text } deriving (Eq, Show, Generic) makeLenses ''JSONError instance FromJSON JSONError where - parseJSON = withObject "JSONError" $ \o -> JSONError - <$> (o .:? "__type" <|> o .:? "Type") - <*> (o .: "message" <|> o .: "Message") + parseJSON = withObject "JSONError" $ \o -> rest o <|> post o + where + rest o = JSONError <$> o .:? "Type" <*> o .: "Message" + post o = JSONError <$> o .:? "__type" <*> o .: "message" jsonError :: FromJSON (Er a) => (Status -> Bool) diff --git a/src/Network/AWS/Request/RestXML.hs b/src/Network/AWS/Request/RestXML.hs --- a/src/Network/AWS/Request/RestXML.hs +++ b/src/Network/AWS/Request/RestXML.hs @@ -14,7 +14,6 @@ , delete , post , put - , stream ) where import Control.Lens @@ -43,10 +42,3 @@ put :: (ToPath a, ToQuery a, ToHeaders a, ToXMLRoot a) => a -> Request a put x = get x & rqMethod .~ PUT & rqBody .~ toBody (encodeXML x) {-# INLINE put #-} - -stream :: (ToPath a, ToQuery a, ToHeaders a, ToBody a) - => StdMethod - -> a - -> Request a -stream m x = get x & rqMethod .~ m & rqBody .~ toBody x -{-# INLINE stream #-} diff --git a/src/Network/AWS/Request/S3.hs b/src/Network/AWS/Request/S3.hs new file mode 100644 --- /dev/null +++ b/src/Network/AWS/Request/S3.hs @@ -0,0 +1,55 @@ +-- Module : Network.AWS.Request.S3 +-- 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.Request.S3 + ( get + , head + , delete + , post + , put + , stream + ) where + +import Control.Lens +import Network.AWS.Data +import Network.AWS.Request.Internal +import Network.AWS.Types +import Network.HTTP.Types.Method +import Prelude hiding (head) + +get :: (ToPath a, ToQuery a, ToHeaders a) => a -> Request a +get = content . defaultRequest +{-# INLINE get #-} + +delete :: (ToPath a, ToQuery a, ToHeaders a) => a -> Request a +delete x = get x & rqMethod .~ DELETE +{-# INLINE delete #-} + +head :: (ToPath a, ToQuery a, ToHeaders a) => a -> Request a +head x = get x & rqMethod .~ HEAD +{-# INLINE head #-} + +post :: (ToPath a, ToQuery a, ToHeaders a, ToXMLRoot a) => a -> Request a +post x = put x & rqMethod .~ POST +{-# INLINE post #-} + +put :: (ToPath a, ToQuery a, ToHeaders a, ToXMLRoot a) => a -> Request a +put x = content $ get x & rqMethod .~ PUT & rqBody .~ toBody (encodeXML x) +{-# INLINE put #-} + +stream :: (ToPath a, ToQuery a, ToHeaders a, ToBody a) + => StdMethod + -> a + -> Request a +stream m x = content $ get x & rqMethod .~ m & rqBody .~ toBody x +{-# INLINE stream #-} + +content :: Request a -> Request a +content rq = rq & rqHeaders %~ hdr hAMZContentSHA256 (bodyHash (rq ^. rqBody)) 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,4 @@ {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} diff --git a/src/Network/AWS/Signing/V4.hs b/src/Network/AWS/Signing/V4.hs --- a/src/Network/AWS/Signing/V4.hs +++ b/src/Network/AWS/Signing/V4.hs @@ -33,6 +33,7 @@ import qualified Data.ByteString.Base16 as Base16 import qualified Data.ByteString.Char8 as BS import qualified Data.CaseInsensitive as CI +import Data.Default.Class import qualified Data.Foldable as Fold import Data.Function import Data.List (groupBy, intersperse, sortBy, sort) @@ -78,12 +79,13 @@ out = finalise Nothing qry service a r rq l t qry cs sh = - pair "X-AMZ-Algorithm" algorithm - . pair "X-AMZ-Credential" cs - . pair "X-AMZ-Date" (LocaleTime l t :: ISO8601) - . pair "X-AMZ-Expires" (LocaleTime l x :: ISO8601) - . pair "X-AMZ-SignedHeaders" sh - . pair "X-AMZ-Security-Token" (toBS <$> _authToken a) + 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 hAMZSignedHeaders) sh + . pair (CI.original hAMZToken) (toBS <$> _authToken a) + . pair (CI.original hAMZContentSHA256) ("UNSIGNED-PAYLOAD" :: ByteString) auth = mappend "&X-AMZ-Signature=" . _mSignature @@ -146,13 +148,16 @@ host' = toBS (endpoint s r) query = qry credentialScope signedHeaders _rqQuery + region | isGlobal s = def + | otherwise = r + canonicalQuery = toBS $ query & valuesOf %~ Just . maybe "" (encodeURI True) & keysOf %~ encodeURI False headers = sortBy (comparing fst) . hdr hHost host' - . hdr hDate (toBS (LocaleTime l t :: ISO8601)) + . hdr hAMZDate (toBS (LocaleTime l t :: AWSTime)) $ _rqHeaders joinedHeaders = map f $ groupBy ((==) `on` fst) headers @@ -179,12 +184,12 @@ , canonicalQuery , canonicalHeaders , signedHeaders - , digestToHexByteString (_bdyHash _rqBody) + , bodyHash _rqBody ] scope = [ toBS (LocaleTime l t :: BasicTime) - , toBS r + , toBS region , toBS _svcPrefix , "aws4_request" ] 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 @@ -51,6 +51,7 @@ , global , regional , custom + , isGlobal -- * Errors , ServiceError (..) @@ -318,6 +319,7 @@ = Global | Regional | Custom ByteString + deriving (Eq) instance IsString Endpoint where fromString = Custom . fromString @@ -338,6 +340,9 @@ custom :: ByteString -> Endpoint custom = Custom +isGlobal :: Service a -> Bool +isGlobal = (== Global) . _svcEndpoint + -- | Attributes specific to an AWS service. data Service a = Service { _svcAbbrev :: !Text @@ -373,6 +378,7 @@ -- | The sum of available AWS regions. data Region = Ireland -- ^ Europe / eu-west-1 + | Frankfurt -- ^ Europe / eu-central-1 | Tokyo -- ^ Asia Pacific / ap-northeast-1 | Singapore -- ^ Asia Pacific / ap-southeast-1 | Sydney -- ^ Asia Pacific / ap-southeast-2 @@ -389,21 +395,26 @@ def = NorthVirginia instance FromText Region where - parser = match "eu-west-1" Ireland - <|> match "ap-northeast-1" Tokyo - <|> match "ap-southeast-1" Singapore - <|> match "ap-southeast-2" Sydney - <|> match "cn-north-1" Beijing - <|> match "us-east-1" NorthVirginia - <|> match "us-west-2" NorthCalifornia - <|> match "us-west-1" Oregon - <|> match "us-gov-west-1" GovCloud - <|> match "fips-us-gov-west-1" GovCloudFIPS - <|> match "sa-east-1" SaoPaulo + parser = takeText >>= \case + "eu-west-1" -> pure Ireland + "eu-central-1" -> pure Frankfurt + "ap-northeast-1" -> pure Tokyo + "ap-southeast-1" -> pure Singapore + "ap-southeast-2" -> pure Sydney + "cn-north-1" -> pure Beijing + "us-east-1" -> pure NorthVirginia + "us-west-2" -> pure NorthCalifornia + "us-west-1" -> pure Oregon + "us-gov-west-1" -> pure GovCloud + "fips-us-gov-west-1" -> pure GovCloudFIPS + "sa-east-1" -> pure SaoPaulo + e -> fail $ + "Failure parsing Region from " ++ show e instance ToText Region where toText r = case r of Ireland -> "eu-west-1" + Frankfurt -> "eu-central-1" Tokyo -> "ap-northeast-1" Singapore -> "ap-southeast-1" Sydney -> "ap-southeast-2"