{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE CPP #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings #-} module Network.API.Mandrill.Types where import Network.API.Mandrill.Utils import Test.QuickCheck import Text.Email.Validate import Data.Char import Data.Maybe import Data.Time import Control.Applicative #if MIN_VERSION_time(1,5,0) import Data.Time.Format (TimeLocale, defaultTimeLocale) #else import System.Locale (TimeLocale, defaultTimeLocale) #endif 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 timeParse :: ParseTime t => TimeLocale -> String -> String -> Maybe t #if MIN_VERSION_time(1,5,0) timeParse = parseTimeM True #else timeParse = parseTime #endif -------------------------------------------------------------------------------- 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 -------------------------------------------------------------------------------- newtype MandrillEmail = MandrillEmail EmailAddress deriving Show instance ToJSON MandrillEmail where toJSON (MandrillEmail e) = String . TL.decodeUtf8 . toByteString $ e instance FromJSON MandrillEmail where parseJSON (String s) = case validate (TL.encodeUtf8 s) of Left err -> fail err Right v -> return . MandrillEmail $ v parseJSON o = typeMismatch "Expecting a String for MandrillEmail." o -------------------------------------------------------------------------------- -- | An array of recipient information. data MandrillRecipient = MandrillRecipient { _mrec_email :: MandrillEmail -- ^ 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 (MandrillEmail email) Nothing Nothing instance Arbitrary MandrillRecipient where arbitrary = pure MandrillRecipient { _mrec_email = MandrillEmail $ 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.preEscapedToHtml 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 data Base64ByteString = EncodedB64BS B.ByteString -- ^ An already-encoded Base64 ByteString. | PlainBS B.ByteString -- ^ A plain Base64 ByteString which requires encoding. deriving Show instance ToJSON Base64ByteString where toJSON (PlainBS bs) = String . TL.decodeUtf8 . Base64.encode $ bs toJSON (EncodedB64BS bs) = String . TL.decodeUtf8 $ bs instance FromJSON Base64ByteString where parseJSON (String v) = pure $ EncodedB64BS (TL.encodeUtf8 v) 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