{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings #-} module Network.API.Mandrill.Types where import Network.API.Mandrill.Utils import Network.API.Mandrill.Orphans() import Test.QuickCheck import Text.Email.Validate import Data.Char import Data.Maybe import Data.Time import Control.Applicative import System.Locale (defaultTimeLocale) import qualified Data.ByteString as B import qualified Data.ByteString.Base64 as Base64 import qualified Data.Text as T import qualified Data.Text.Encoding as TL import qualified Data.Text.Lazy as TL import Control.Lens import Data.Monoid import Data.Aeson import Data.Aeson.Types import Data.Aeson.TH import qualified Text.Blaze.Html as Blaze import qualified Text.Blaze.Html.Renderer.Text as Blaze -------------------------------------------------------------------------------- data MandrillError = MandrillError { _merr_status :: !T.Text , _merr_code :: !Int , _merr_name :: !T.Text , _merr_message :: !T.Text } deriving Show makeLenses ''MandrillError deriveJSON defaultOptions { fieldLabelModifier = drop 6 } ''MandrillError -------------------------------------------------------------------------------- data MandrillEmailStatus = ES_Sent | ES_Queued | ES_Scheduled | ES_Rejected | ES_Invalid deriving Show deriveJSON defaultOptions { constructorTagModifier = map toLower . drop 3 } ''MandrillEmailStatus -------------------------------------------------------------------------------- data MandrillRejectReason = RR_HardBounce | RR_SoftBounce | RR_Spam | RR_Unsub | RR_Custom | RR_InvalidSender | RR_Invalid | RR_TestModeLimit | RR_Rule deriving Show deriveJSON defaultOptions { constructorTagModifier = modRejectReason . drop 3 } ''MandrillRejectReason -------------------------------------------------------------------------------- -- | The main datatypes which models the response from the Mandrill API, -- which can be either a success or a failure. data MandrillResponse k = MandrillSuccess k | MandrillFailure MandrillError deriving Show instance FromJSON k => FromJSON (MandrillResponse k) where parseJSON v = case (parseMaybe parseJSON v) :: Maybe k of Just r -> return $ MandrillSuccess r Nothing -> do -- try to parse it as an error case (parseMaybe parseJSON v) :: Maybe MandrillError of Just e -> return $ MandrillFailure e Nothing -> fail $ show v <> " is neither a MandrillSuccess or a MandrillError." -------------------------------------------------------------------------------- data MandrillRecipientTag = To | Cc | Bcc deriving Show deriveJSON defaultOptions { constructorTagModifier = map toLower } ''MandrillRecipientTag -------------------------------------------------------------------------------- -- | An array of recipient information. data MandrillRecipient = MandrillRecipient { _mrec_email :: EmailAddress -- ^ The email address of the recipient , _mrec_name :: Maybe T.Text -- ^ The optional display name to use for the recipient , _mrec_type :: Maybe MandrillRecipientTag -- ^ The header type to use for the recipient. -- defaults to "to" if not provided } deriving Show makeLenses ''MandrillRecipient deriveJSON defaultOptions { fieldLabelModifier = drop 6 } ''MandrillRecipient newRecipient :: EmailAddress -> MandrillRecipient newRecipient email = MandrillRecipient email Nothing Nothing instance Arbitrary MandrillRecipient where arbitrary = pure MandrillRecipient { _mrec_email = fromJust (emailAddress "test@example.com") , _mrec_name = Nothing , _mrec_type = Nothing } -------------------------------------------------------------------------------- newtype MandrillHtml = MandrillHtml Blaze.Html unsafeMkMandrillHtml :: T.Text -> MandrillHtml unsafeMkMandrillHtml = MandrillHtml . Blaze.preEscapedToHtml -- This might be slightly hairy because it violates -- the nice encapsulation that newtypes offer. mkMandrillHtml :: Blaze.Html -> MandrillHtml mkMandrillHtml = MandrillHtml instance Monoid MandrillHtml where mempty = MandrillHtml mempty mappend (MandrillHtml m1) (MandrillHtml m2) = MandrillHtml (m1 <> m2) instance Show MandrillHtml where show (MandrillHtml h) = show $ Blaze.renderHtml h instance ToJSON MandrillHtml where toJSON (MandrillHtml h) = String . TL.toStrict . Blaze.renderHtml $ h instance FromJSON MandrillHtml where parseJSON (String h) = return $ MandrillHtml (Blaze.toHtml h) parseJSON v = typeMismatch "Expecting a String for MandrillHtml" v instance Arbitrary MandrillHtml where arbitrary = pure $ mkMandrillHtml "
FooBar
" -------------------------------------------------------------------------------- type MandrillTags = T.Text -------------------------------------------------------------------------------- type MandrillHeaders = Value -------------------------------------------------------------------------------- type MandrillVars = Value -------------------------------------------------------------------------------- data MandrillMergeVars = MandrillMergeVars { _mmvr_rcpt :: !T.Text , _mmvr_vars :: [MandrillVars] } deriving Show makeLenses ''MandrillMergeVars deriveJSON defaultOptions { fieldLabelModifier = drop 6 } ''MandrillMergeVars -------------------------------------------------------------------------------- data MandrillMetadata = MandrillMetadata { _mmdt_rcpt :: !T.Text , _mmdt_values :: MandrillVars } deriving Show makeLenses ''MandrillMetadata deriveJSON defaultOptions { fieldLabelModifier = drop 6 } ''MandrillMetadata newtype Base64ByteString = B64BS B.ByteString deriving Show instance ToJSON Base64ByteString where toJSON (B64BS bs) = String . TL.decodeUtf8 . Base64.encode $ bs instance FromJSON Base64ByteString where parseJSON (String v) = case Base64.decode (TL.encodeUtf8 v) of Left err -> fail err Right rs -> return $ B64BS rs parseJSON rest = typeMismatch "Base64ByteString must be a String." rest -------------------------------------------------------------------------------- data MandrillWebContent = MandrillWebContent { _mwct_type :: !T.Text , _mwct_name :: !T.Text -- ^ [for images] the Content ID of the image -- - use