Validate.hs

module Amazon.SNS.Verify.Validate
  ( validateSnsMessage
  , handleSubscription
  , SNSNotificationValidationError (..)
  , ValidSNSMessage (..)
  ) where

import Amazon.SNS.Verify.Prelude

import Amazon.SNS.Verify.Payload
import Amazon.SNS.Verify.ValidURI (validRegPattern, validScheme)
import Control.Error (ExceptT, catMaybes, headMay, runExceptT, throwE)
import Control.Monad (unless, when)
import Data.ByteArray.Encoding (Base (Base64), convertFromBase)
import Data.PEM (pemContent, pemParseLBS)
import qualified Data.Text as T
import Data.Text.Encoding (encodeUtf8)
import Data.X509
  ( HashALG (..)
  , PubKeyALG (..)
  , SignatureALG (..)
  , SignedCertificate
  , certPubKey
  , decodeSignedCertificate
  , getCertificate
  )
import Data.X509.Validation
  ( SignatureFailure
  , SignatureVerification (..)
  , verifySignature
  )
import Network.HTTP.Simple
  ( getResponseBody
  , getResponseStatusCode
  , httpLbs
  , parseRequest_
  )
import Network.URI (parseURI, uriAuthority, uriRegName, uriScheme)
import Text.Regex.TDFA ((=~))

data ValidSNSMessage
  = SNSMessage Text
  | SNSSubscribe SNSSubscription
  | SNSUnsubscribe SNSSubscription
  deriving stock (Show, Eq)

-- | Validate SNS notification
--
-- SNS messages are validated through their signature. The algorithm is detailed
-- in the documentation below.
--
-- <https://docs.aws.amazon.com/sns/latest/dg/sns-verify-signature-of-message.html>
validateSnsMessage
  :: MonadIO m
  => SNSPayload
  -> m (Either SNSNotificationValidationError ValidSNSMessage)
validateSnsMessage payload@SNSPayload {..} = runExceptT $ do
  signature <-
    unTryE BadSignature
      $ convertFromBase Base64
      $ encodeUtf8
        snsSignature
  signedCert <- retrieveCertificate payload
  let valid =
        verifySignature
          (SignatureALG HashSHA1 PubKeyALG_RSA)
          (certPubKey $ getCertificate signedCert)
          (unsignedSignature payload)
          signature
  case valid of
    SignaturePass -> pure $ case snsTypePayload of
      Notification {} -> SNSMessage snsMessage
      SubscriptionConfirmation x -> SNSSubscribe x
      UnsubscribeConfirmation x -> SNSUnsubscribe x
    SignatureFailed e -> throwE $ InvalidPayload e

retrieveCertificate
  :: MonadIO m
  => SNSPayload
  -> ExceptT SNSNotificationValidationError m SignedCertificate
retrieveCertificate SNSPayload {..} = do
  certUrlStr <- validateCertUrl snsSigningCertURL
  response <- httpLbs $ parseRequest_ certUrlStr
  pems <- unTryE BadPem $ pemParseLBS $ getResponseBody response
  cert <-
    fromMaybeM (throwE $ BadPem "Empty List") $ pemContent <$> headMay pems
  unTryE BadCert $ decodeSignedCertificate cert

validateCertUrl
  :: Monad m => Text -> ExceptT SNSNotificationValidationError m String
validateCertUrl certUrl = do
  uri <- fromMaybeM (throwE $ BadUri certUrlStr) $ parseURI certUrlStr

  let
    scheme = uriScheme uri
    mDomain = uriRegName <$> uriAuthority uri

  unless (scheme == validScheme) $ throwE $ BadScheme scheme validScheme
  domain <- fromMaybeM (throwE $ NoAuthority certUrlStr) mDomain
  unless (domain =~ validRegPattern) $ throwE $ BadDomain domain validRegPattern

  pure certUrlStr
 where
  certUrlStr = T.unpack certUrl

unsignedSignature :: SNSPayload -> ByteString
unsignedSignature SNSPayload {..} =
  encodeUtf8
    $ mconcat
    $ (<> "\n")
    <$> catMaybes
      [ Just "Message"
      , Just snsMessage
      , Just "MessageId"
      , Just snsMessageId
      , "SubscribeURL" <$ mSubscribeUrl
      , mSubscribeUrl
      , "Subject" <$ mSubject
      , mSubject
      , Just "Timestamp"
      , Just snsTimestamp
      , "Token" <$ mToken
      , mToken
      , Just "TopicArn"
      , Just snsTopicArn
      , Just "Type"
      , Just snsType
      ]
 where
  (mSubject, mToken, mSubscribeUrl) = case snsTypePayload of
    Notification x -> (snsSubject x, Nothing, Nothing)
    SubscriptionConfirmation x ->
      (Nothing, Just $ snsToken x, Just $ snsSubscribeURL x)
    UnsubscribeConfirmation x ->
      (Nothing, Just $ snsToken x, Just $ snsSubscribeURL x)

handleSubscription
  :: MonadIO m
  => ValidSNSMessage
  -> m (Either SNSNotificationValidationError Text)
handleSubscription =
  runExceptT . \case
    SNSMessage t -> pure t
    SNSSubscribe SNSSubscription {..} -> do
      response <- httpLbs $ parseRequest_ $ T.unpack snsSubscribeURL
      when (getResponseStatusCode response >= 300) $ do
        throwE BadSubscription
      throwE SubscribeMessageResponded
    SNSUnsubscribe {} -> throwE UnsubscribeMessage

data SNSNotificationValidationError
  = BadPem String
  | BadUri String
  | BadScheme String String
  | NoAuthority String
  | BadDomain String String
  | BadSignature String
  | BadCert String
  | BadJSONParse String
  | BadSubscription
  | InvalidPayload SignatureFailure
  | MissingMessageTypeHeader
  | UnsubscribeMessage
  | SubscribeMessageResponded
  deriving stock (Show, Eq)

instance Exception SNSNotificationValidationError where
  displayException = \case
    BadScheme actual expected ->
      "BadScheme, expected "
        <> expected
        <> " but got "
        <> actual
    BadDomain actual regex ->
      "BadDomain, "
        <> actual
        <> " does not match the regular expression "
        <> regex
    ex -> show ex