module Aws.Sns.Core
(
SnsVersion(..)
, SnsConfiguration(..)
, SnsMetadata(..)
, SnsErrorResponse(..)
, SnsProtocol(..)
, snsProtocolToText
, parseSnsProtocol
, SnsEndpoint
, SnsAction(..)
, snsActionToText
, parseSnsAction
, snsServiceEndpoint
, SnsQuery(..)
, snsSignQuery
, snsResponseConsumer
, snsXmlResponseConsumer
, snsErrorResponseConsumer
, SnsError(..)
, SnsCommonParameters(..)
, SnsCommonError(..)
) where
import Aws.Core
import Aws.General
import Aws.SignatureV4
import qualified Blaze.ByteString.Builder as BB
import Control.Applicative
import Control.Exception
import Control.Monad.IO.Class
import Control.Monad.Trans.Resource (throwM)
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as B8
import Data.Conduit (($$+-))
import Data.IORef
import Data.Maybe
import Data.Monoid
import Data.String
import Data.Time.Clock
import Data.Typeable
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Network.HTTP.Types as HTTP
import qualified Network.HTTP.Conduit as HTTP
import qualified Test.QuickCheck as Q
import qualified Text.Parser.Char as P
import Text.Parser.Combinators ((<?>))
import qualified Text.XML as XML
import qualified Text.XML.Cursor as CU
import Text.XML.Cursor (($//))
data SnsVersion
= SnsVersion_2013_03_31
data SnsAction
= SnsActionAddPermission
| SnsActionConfirmSubscription
| SnsActionCreatePlatformApplication
| SnsActionCreatePlatformEndpoint
| SnsActionCreateTopic
| SnsActionDeleteEndPoint
| SnsActionDeletePlatformApplication
| SnsActionDeleteTopic
| SnsActionGetEndpointAttributes
| SnsActionGetPlatformApplicationAttribute
| SnsActionGetSubscriptionAttributes
| SnsActionGetTopicAttributes
| SnsActionListEndpointsByPlatformApplication
| SnsActionListPlatformApplications
| SnsActionListSubscriptions
| SnsActionListSubscriptionsByTopic
| SnsActionListTopics
| SnsActionPublish
| SnsActionRemovePermission
| SnsActionSetEndpointAttributes
| SnsActionSetPlatformApplicationAttributes
| SnsActionSetSubscriptionAttributes
| SnsActionSetTopicAttributes
| SnsActionSubscribe
| SnsActionUnsubscribe
deriving (Show, Read, Eq, Ord, Enum, Bounded, Typeable)
snsActionToText :: IsString a => SnsAction -> a
snsActionToText SnsActionAddPermission = "AddPermission"
snsActionToText SnsActionConfirmSubscription = "ConfirmSubscription"
snsActionToText SnsActionCreatePlatformApplication = "CreatePlatformApplication"
snsActionToText SnsActionCreatePlatformEndpoint = "CreatePlatformEndpoint"
snsActionToText SnsActionCreateTopic = "CreateTopic"
snsActionToText SnsActionDeleteEndPoint = "DeleteEndPoint"
snsActionToText SnsActionDeletePlatformApplication = "DeletePlatformApplication"
snsActionToText SnsActionDeleteTopic = "DeleteTopic"
snsActionToText SnsActionGetEndpointAttributes = "GetEndpointAttributes"
snsActionToText SnsActionGetPlatformApplicationAttribute = "GetPlatformApplicationAttribute"
snsActionToText SnsActionGetSubscriptionAttributes = "GetSubscriptionAttributes"
snsActionToText SnsActionGetTopicAttributes = "GetTopicAttributes"
snsActionToText SnsActionListEndpointsByPlatformApplication = "ListEndpointsByPlatformApplication"
snsActionToText SnsActionListPlatformApplications = "ListPlatformApplications"
snsActionToText SnsActionListSubscriptions = "ListSubscriptions"
snsActionToText SnsActionListSubscriptionsByTopic = "ListSubscriptionsByTopic"
snsActionToText SnsActionListTopics = "ListTopics"
snsActionToText SnsActionPublish = "Publish"
snsActionToText SnsActionRemovePermission = "RemovePermission"
snsActionToText SnsActionSetEndpointAttributes = "SetEndpointAttributes"
snsActionToText SnsActionSetPlatformApplicationAttributes = "SetPlatformApplicationAttributes"
snsActionToText SnsActionSetSubscriptionAttributes = "SetSubscriptionAttributes"
snsActionToText SnsActionSetTopicAttributes = "SetTopicAttributes"
snsActionToText SnsActionSubscribe = "Subscribe"
snsActionToText SnsActionUnsubscribe = "Unsubscribe"
parseSnsAction :: P.CharParsing m => m SnsAction
parseSnsAction =
SnsActionAddPermission <$ P.text "AddPermission"
<|> SnsActionConfirmSubscription <$ P.text "ConfirmSubscription"
<|> SnsActionCreatePlatformApplication <$ P.text "CreatePlatformApplication"
<|> SnsActionCreatePlatformEndpoint <$ P.text "CreatePlatformEndpoint"
<|> SnsActionCreateTopic <$ P.text "CreateTopic"
<|> SnsActionDeleteEndPoint <$ P.text "DeleteEndPoint"
<|> SnsActionDeletePlatformApplication <$ P.text "DeletePlatformApplication"
<|> SnsActionDeleteTopic <$ P.text "DeleteTopic"
<|> SnsActionGetEndpointAttributes <$ P.text "GetEndpointAttributes"
<|> SnsActionGetPlatformApplicationAttribute <$ P.text "GetPlatformApplicationAttribute"
<|> SnsActionGetSubscriptionAttributes <$ P.text "GetSubscriptionAttributes"
<|> SnsActionGetTopicAttributes <$ P.text "GetTopicAttributes"
<|> SnsActionListEndpointsByPlatformApplication <$ P.text "ListEndpointsByPlatformApplication"
<|> SnsActionListPlatformApplications <$ P.text "ListPlatformApplications"
<|> SnsActionListSubscriptions <$ P.text "ListSubscriptions"
<|> SnsActionListSubscriptionsByTopic <$ P.text "ListSubscriptionsByTopic"
<|> SnsActionListTopics <$ P.text "ListTopics"
<|> SnsActionPublish <$ P.text "Publish"
<|> SnsActionRemovePermission <$ P.text "RemovePermission"
<|> SnsActionSetEndpointAttributes <$ P.text "SetEndpointAttributes"
<|> SnsActionSetPlatformApplicationAttributes <$ P.text "SetPlatformApplicationAttributes"
<|> SnsActionSetSubscriptionAttributes <$ P.text "SetSubscriptionAttributes"
<|> SnsActionSetTopicAttributes <$ P.text "SetTopicAttributes"
<|> SnsActionSubscribe <$ P.text "Subscribe"
<|> SnsActionUnsubscribe <$ P.text "Unsubscribe"
<?> "SnsAction"
instance AwsType SnsAction where
toText = snsActionToText
parse = parseSnsAction
instance Q.Arbitrary SnsAction where
arbitrary = Q.elements [minBound..maxBound]
snsServiceEndpoint :: Region -> B8.ByteString
snsServiceEndpoint ApNortheast1 = "sns.ap-northeast-1.amazonaws.com"
snsServiceEndpoint ApSoutheast1 = "sns.ap-southeast-1.amazonaws.com"
snsServiceEndpoint ApSoutheast2 = "sns.ap-southeast-2.amazonaws.com"
snsServiceEndpoint EuWest1 = "sns.eu-west-1.amazonaws.com"
snsServiceEndpoint SaEast1 = "sns.sa-east-1.amazonaws.com"
snsServiceEndpoint UsEast1 = "sns.us-east-1.amazonaws.com"
snsServiceEndpoint UsWest1 = "sns.us-west-1.amazonaws.com"
snsServiceEndpoint UsWest2 = "sns.us-west-2.amazonaws.com"
data SnsMetadata = SnsMetadata
{ snsMAmzId2 :: Maybe T.Text
, snsMRequestId :: Maybe T.Text
}
deriving (Show)
instance Loggable SnsMetadata where
toLogText (SnsMetadata rid id2) =
"SNS: request ID=" <> fromMaybe "<none>" rid
<> ", x-amz-id-2=" <> fromMaybe "<none>" id2
instance Monoid SnsMetadata where
mempty = SnsMetadata Nothing Nothing
SnsMetadata id1 r1 `mappend` SnsMetadata id2 r2 = SnsMetadata (id1 <|> id2) (r1 <|> r2)
data SnsConfiguration qt = SnsConfiguration
{ snsConfProtocol :: Protocol
, snsConfRegion :: Region
}
deriving (Show)
data SnsQuery = SnsQuery
{ snsQueryMethod :: !Method
, snsQueryAction :: !SnsAction
, snsQueryParameters :: !HTTP.QueryText
, snsQueryBody :: !(Maybe B.ByteString)
}
deriving (Show, Eq)
snsSignQuery :: SnsQuery -> SnsConfiguration qt -> SignatureData -> SignedQuery
snsSignQuery query conf sigData = SignedQuery
{ sqMethod = method
, sqProtocol = snsConfProtocol conf
, sqHost = host
, sqPort = port
, sqPath = BB.toByteString $ HTTP.encodePathSegments path
, sqQuery = HTTP.queryTextToQuery signedQuery
, sqDate = Nothing
, sqAuthorization = authorization
, sqContentType = contentType
, sqContentMd5 = Nothing
, sqAmzHeaders = amzHeaders
, sqOtherHeaders = []
, sqBody = HTTP.RequestBodyBS <$> body
, sqStringToSign = mempty
}
where
action = snsQueryAction query
path = []
host = snsServiceEndpoint $ snsConfRegion conf
headers = [("host", host)]
port = case snsConfProtocol conf of
HTTP -> 80
HTTPS -> 443
contentType = case snsQueryMethod query of
Post -> Just "application/json"
Get -> Nothing
PostQuery -> Just "application/x-www-form-urlencoded; charset=utf-8"
Put -> Just "application/json"
Delete -> Nothing
Head -> Nothing
method = case snsQueryMethod query of
PostQuery -> Post
x -> x
body = case snsQueryMethod query of
PostQuery -> Just $ BB.toByteString $ HTTP.renderQueryText False
$ ("Action", Just . toText $ action) : snsQueryParameters query
_ -> snsQueryBody query
unsignedQuery = case snsQueryMethod query of
PostQuery -> []
_ -> ("Action", Just . toText $ action) : snsQueryParameters query
(signedQuery, amzHeaders, authorization) = case method of
Get -> (getQuery, getAmzHeaders, getAuthorization)
Head -> (getQuery, getAmzHeaders, getAuthorization)
Delete -> (getQuery, getAmzHeaders, getAuthorization)
Post -> (postQuery, postAmzHeaders, postAuthorization)
PostQuery -> (postQuery, postAmzHeaders, postAuthorization)
Put -> (postQuery, postAmzHeaders, postAuthorization)
postAmzHeaders = filter ((/= "Authorization") . fst) postSignature
postAuthorization = return <$> lookup "authorization" postSignature
postQuery = unsignedQuery
postSignature = either error id $ signPostRequest
(cred2cred $ signatureCredentials sigData)
(snsConfRegion conf)
ServiceNamespaceSns
(signatureTime sigData)
(httpMethod method)
path
unsignedQuery
headers
(fromMaybe "" body)
getAmzHeaders = headers
getAuthorization = Nothing
getQuery = getSignature
getSignature = either error id $ signGetRequest
(cred2cred $ signatureCredentials sigData)
(snsConfRegion conf)
ServiceNamespaceSns
(signatureTime sigData)
(httpMethod method)
path
unsignedQuery
headers
(fromMaybe "" body)
#if MIN_VERSION_aws(0,9,2)
cred2cred (Credentials a b c _) = SignatureV4Credentials a b c
#else
cred2cred (Credentials a b c) = SignatureV4Credentials a b c
#endif
snsResponseConsumer
:: HTTPResponseConsumer a
-> IORef SnsMetadata
-> HTTPResponseConsumer a
snsResponseConsumer inner metadata resp = do
let headerString = fmap T.decodeUtf8 . flip lookup (HTTP.responseHeaders resp)
amzId2 = headerString "x-amz-id-2"
requestId = headerString "x-amz-request-id"
m = SnsMetadata { snsMAmzId2 = amzId2, snsMRequestId = requestId }
liftIO $ tellMetadataRef metadata m
if HTTP.responseStatus resp >= HTTP.status400
then snsErrorResponseConsumer resp
else inner resp
snsXmlResponseConsumer
:: (CU.Cursor -> Response SnsMetadata a)
-> IORef SnsMetadata
-> HTTPResponseConsumer a
snsXmlResponseConsumer p metadataRef =
snsResponseConsumer (xmlCursorConsumer p metadataRef) metadataRef
snsErrorResponseConsumer :: HTTPResponseConsumer a
snsErrorResponseConsumer resp = do
doc <- HTTP.responseBody resp $$+- XML.sinkDoc XML.def
case parseError (CU.fromDocument doc) of
Right err -> liftIO $ throwM err
Left otherErr -> do
liftIO $ throwM otherErr
where
parseError root = SnsErrorResponse
<$> pure (HTTP.responseStatus resp)
<*> (force "Missing error Code" $ root $// elContent "Code")
<*> (force "Missing error Message" $ root $// elContent "Message")
<*> pure (listToMaybe $ root $// elContent "Resource")
<*> pure (listToMaybe $ root $// elContent "HostId")
<*> pure (listToMaybe $ root $// elContent "AWSAccessKeyId")
<*> (pure $ do
unprocessed <- listToMaybe $ root $// elCont "StringToSignBytes"
B.pack <$> mapM readHex2 (words unprocessed))
data SnsError a
= SnsErrorCommon SnsCommonError
| SnsErrorCommand a
deriving (Show, Read, Eq, Ord, Typeable)
data SnsErrorResponse
= SnsErrorResponse
{ snsErrorStatusCode :: !HTTP.Status
, snsErrorCode :: !T.Text
, snsErrorMessage :: !T.Text
, snsErrorResource :: !(Maybe T.Text)
, snsErrorHostId :: !(Maybe T.Text)
, snsErrorAccessKeyId :: !(Maybe T.Text)
, snsErrorStringToSign :: !(Maybe B.ByteString)
}
| SnsResponseDecodeError T.Text
deriving (Show, Eq, Ord, Typeable)
instance Exception SnsErrorResponse
data SnsCommonError
= ErrorIncompleteSignature
| ErrorInternalFailure
| ErrorInvalidAction
| ErrorInvalidClientTokenId
| ErrorInvalidParameterCombination
| ErrorInvalidParameterValue
| ErrorInvalidQueryParamter
| ErrorMalformedQueryString
| ErrorMissingAction
| ErrorMissingAuthenticationToken
| ErrorMissingParameter
| ErrorOptInRequired
| ErrorRequestExpired
| ErrorServiceUnavailable
| ErrorThrottling
| ErrorValidationError
deriving (Show, Read, Eq, Ord, Enum, Bounded, Typeable)
data SnsProtocol
= SnsProtocolHttp
| SnsProtocolHttps
| SnsProtocolEmail
| SnsProtocolEmailJson
| SnsProtocolSms
| SnsProtocolSqs
| SnsProtocolApplication
deriving (Show, Read, Eq, Ord, Enum, Bounded, Typeable)
snsProtocolToText :: IsString a => SnsProtocol -> a
snsProtocolToText SnsProtocolHttp = "http"
snsProtocolToText SnsProtocolHttps = "https"
snsProtocolToText SnsProtocolEmail = "email"
snsProtocolToText SnsProtocolEmailJson = "email-json"
snsProtocolToText SnsProtocolSms = "sms"
snsProtocolToText SnsProtocolSqs = "sqs"
snsProtocolToText SnsProtocolApplication = "application"
parseSnsProtocol :: P.CharParsing m => m SnsProtocol
parseSnsProtocol =
SnsProtocolHttp <$ P.text "http"
<|> SnsProtocolHttps <$ P.text "https"
<|> SnsProtocolEmail <$ P.text "email"
<|> SnsProtocolEmailJson <$ P.text "email-json"
<|> SnsProtocolSms <$ P.text "sms"
<|> SnsProtocolSqs <$ P.text "sqs"
<|> SnsProtocolApplication <$ P.text "application"
<?> "SnsProtocol"
instance AwsType SnsProtocol where
toText = snsProtocolToText
parse = parseSnsProtocol
instance Q.Arbitrary SnsProtocol where
arbitrary = Q.elements [minBound..maxBound]
type SnsEndpoint = T.Text
data SnsCommonParameters = SnsCommonParameters
{ snsAction :: !SnsAction
, snsParams :: ()
, snsAWSAccessKeyId :: !B8.ByteString
, snsExpires :: !UTCTime
, snsTimestamp :: !UTCTime
, snsSecurityToken :: ()
, snsSignature :: !Signature
, snsSignatureMethod :: !SignatureMethod
, snsSignatureVersion :: !SignatureVersion
, snsVersion :: SnsVersion
}