content: module Aws.Ses.Core
      ( SesError(..)
      , SesMetadata(..)
  
      , SesConfiguration(..)
      , sesEuWest1
      , sesUsEast
      , sesUsEast1
      , sesUsWest2
      , sesHttpsGet
      , sesHttpsPost
  
      , sesSignQuery
  
      , sesResponseConsumer
  
      , RawMessage(..)
      , Destination(..)
      , EmailAddress
      , Sender(..)
      , sesAsQuery
      ) where
  
  import           Aws.Core
  import qualified Blaze.ByteString.Builder       as Blaze
  import qualified Blaze.ByteString.Builder.Char8 as Blaze8
  import qualified Control.Exception              as C
  import           Control.Monad                  (mplus)
  import           Control.Monad.Trans.Resource   (throwM)
  import qualified Data.ByteString                as B
  import qualified Data.ByteString.Base64         as B64
  import           Data.ByteString.Char8          ({-IsString-})
  import           Data.IORef
  import           Data.Maybe
  import           Data.Monoid
  import qualified Data.Semigroup                 as Sem
  import           Data.Text                      (Text)
  import qualified Data.Text.Encoding             as TE
  import           Data.Typeable
  import           Prelude
  import qualified Network.HTTP.Conduit           as HTTP
  import qualified Network.HTTP.Types             as HTTP
  import           Text.XML.Cursor                (($/), ($//))
  import qualified Text.XML.Cursor                as Cu
  
  data SesError
      = SesError {
          sesStatusCode   :: HTTP.Status
        , sesErrorCode    :: Text
        , sesErrorMessage :: Text
        }
      deriving (Show, Typeable)
  
  instance C.Exception SesError
  
  data SesMetadata
      = SesMetadata {
          requestId :: Maybe Text
        }
      deriving (Show, Typeable)
  
  instance Loggable SesMetadata where
      toLogText (SesMetadata rid) = "SES: request ID=" `mappend` fromMaybe "<none>" rid
  
  instance Sem.Semigroup SesMetadata where
      SesMetadata r1 <> SesMetadata r2 = SesMetadata (r1 `mplus` r2)
  
  instance Monoid SesMetadata where
      mempty = SesMetadata Nothing
      mappend = (Sem.<>)
  
  data SesConfiguration qt
      = SesConfiguration {
          sesiHttpMethod :: Method
        , sesiHost       :: B.ByteString
        }
      deriving (Show)
  
  -- HTTP is not supported right now, always use HTTPS
  instance DefaultServiceConfiguration (SesConfiguration NormalQuery) where
      defServiceConfig = sesHttpsPost sesUsEast1
  
  instance DefaultServiceConfiguration (SesConfiguration UriOnlyQuery) where
      defServiceConfig = sesHttpsGet sesUsEast1
  
  sesEuWest1 :: B.ByteString
  sesEuWest1 = "email.eu-west-1.amazonaws.com"
  
  sesUsEast :: B.ByteString
  sesUsEast = sesUsEast1
  
  sesUsEast1 :: B.ByteString
  sesUsEast1 = "email.us-east-1.amazonaws.com"
  
  sesUsWest2 :: B.ByteString
  sesUsWest2 = "email.us-west-2.amazonaws.com"
  
  sesHttpsGet :: B.ByteString -> SesConfiguration qt
  sesHttpsGet endpoint = SesConfiguration Get endpoint
  
  sesHttpsPost :: B.ByteString -> SesConfiguration NormalQuery
  sesHttpsPost endpoint = SesConfiguration PostQuery endpoint
  
  sesSignQuery :: [(B.ByteString, B.ByteString)] -> SesConfiguration qt -> SignatureData -> SignedQuery
  sesSignQuery query si sd
      = SignedQuery {
          sqMethod        = sesiHttpMethod si
        , sqProtocol      = HTTPS
        , sqHost          = sesiHost si
        , sqPort          = defaultPort HTTPS
        , sqPath          = "/"
        , sqQuery         = HTTP.simpleQueryToQuery query'
        , sqDate          = Just $ signatureTime sd
        , sqAuthorization = Nothing
        , sqContentType   = Nothing
        , sqContentMd5    = Nothing
        , sqAmzHeaders    = amzHeaders
        , sqOtherHeaders  = []
        , sqBody          = Nothing
        , sqStringToSign  = stringToSign
        }
      where
        stringToSign  = fmtRfc822Time (signatureTime sd)
        credentials   = signatureCredentials sd
        accessKeyId   = accessKeyID credentials
        amzHeaders    = catMaybes
                      [ Just ("X-Amzn-Authorization", authorization)
                      , ("x-amz-security-token",) `fmap` iamToken credentials
                      ]
        authorization = B.concat
                      [ "AWS3-HTTPS AWSAccessKeyId="
                      , accessKeyId
                      , ", Algorithm=HmacSHA256, Signature="
                      , signature credentials HmacSHA256 stringToSign
                      ]
        query' = ("AWSAccessKeyId", accessKeyId) : query
  
  sesResponseConsumer :: (Cu.Cursor -> Response SesMetadata a)
                      -> IORef SesMetadata
                      -> HTTPResponseConsumer a
  sesResponseConsumer inner metadataRef resp = xmlCursorConsumer parse metadataRef resp
      where
        parse cursor = do
          let requestId' = listToMaybe $ cursor $// elContent "RequestID"
          tellMetadata $ SesMetadata requestId'
          case cursor $/ Cu.laxElement "Error" of
            []      -> inner cursor
            (err:_) -> fromError err
  
        fromError cursor = do
          errCode    <- force "Missing Error Code"    $ cursor $// elContent "Code"
          errMessage <- force "Missing Error Message" $ cursor $// elContent "Message"
          throwM $ SesError (HTTP.responseStatus resp) errCode errMessage
  
  class SesAsQuery a where
      -- | Write a data type as a list of query parameters.
      sesAsQuery :: a -> [(B.ByteString, B.ByteString)]
  
  instance SesAsQuery a => SesAsQuery (Maybe a) where
      sesAsQuery = maybe [] sesAsQuery
  
  
  -- | A raw e-mail.
  data RawMessage = RawMessage { rawMessageData :: B.ByteString }
                  deriving (Eq, Ord, Show, Typeable)
  
  instance SesAsQuery RawMessage where
      sesAsQuery = (:[]) . (,) "RawMessage.Data" . B64.encode . rawMessageData
  
  
  -- | The destinations of an e-mail.
  data Destination =
      Destination
        { destinationBccAddresses :: [EmailAddress]
        , destinationCcAddresses  :: [EmailAddress]
        , destinationToAddresses  :: [EmailAddress]
        } deriving (Eq, Ord, Show, Typeable)
  
  instance SesAsQuery Destination where
      sesAsQuery (Destination bcc cc to) = concat [ go (s "Bcc") bcc
                                                  , go (s "Cc")  cc
                                                  , go (s "To")  to ]
          where
            go kind = zipWith f (map Blaze8.fromShow [one..])
                where txt = kind `mappend` s "Addresses.member."
                      f n v = ( Blaze.toByteString (txt `mappend` n)
                              , TE.encodeUtf8 v )
            s = Blaze.fromByteString
            one = 1 :: Int
  
  instance Sem.Semigroup Destination where
      (Destination a1 a2 a3) <> (Destination b1 b2 b3) =
          Destination (a1 ++ b1) (a2 ++ b2) (a3 ++ b3)
  
  instance Monoid Destination where
      mempty = Destination [] [] []
      mappend = (Sem.<>)
  
  -- | An e-mail address.
  type EmailAddress = Text
  
  
  -- | The sender's e-mail address.
  data Sender = Sender { senderAddress :: EmailAddress }
                deriving (Eq, Ord, Show, Typeable)
  
  instance SesAsQuery Sender where
      sesAsQuery = (:[]) . (,) "Source" . TE.encodeUtf8 . senderAddress
  