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 Data.Time (ParseTime)
#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
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
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
data MandrillRecipient = MandrillRecipient {
_mrec_email :: EmailAddress
, _mrec_name :: Maybe T.Text
, _mrec_type :: Maybe MandrillRecipientTag
} 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
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 "<p><b>FooBar</b></p>"
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
, _mwct_content :: !Base64ByteString
} deriving Show
makeLenses ''MandrillWebContent
deriveJSON defaultOptions { fieldLabelModifier = drop 6 } ''MandrillWebContent
data MandrillMessage = MandrillMessage {
_mmsg_html :: MandrillHtml
, _mmsg_text :: Maybe T.Text
, _mmsg_subject :: !T.Text
, _mmsg_from_email :: EmailAddress
, _mmsg_from_name :: Maybe T.Text
, _mmsg_to :: [MandrillRecipient]
, _mmsg_headers :: MandrillHeaders
, _mmsg_important :: Maybe Bool
, _mmsg_track_opens :: Maybe Bool
, _mmsg_track_clicks :: Maybe Bool
, _mmsg_auto_text :: Maybe Bool
, _mmsg_auto_html :: Maybe Bool
, _mmsg_inline_css :: Maybe Bool
, _mmsg_url_strip_qs :: Maybe Bool
, _mmsg_preserve_recipients :: Maybe Bool
, _mmsg_view_content_link :: Maybe Bool
, _mmsg_bcc_address :: Maybe T.Text
, _mmsg_tracking_domain :: Maybe T.Text
, _mmsg_signing_domain :: Maybe Bool
, _mmsg_return_path_domain :: Maybe Bool
, _mmsg_merge :: Maybe Bool
, _mmsg_global_merge_vars :: [MandrillVars]
, _mmsg_merge_vars :: [MandrillMergeVars]
, _mmsg_tags :: [MandrillTags]
, _mmsg_subaccount :: Maybe T.Text
, _mmsg_google_analytics_domains :: [T.Text]
, _mmsg_google_analytics_campaign :: Maybe T.Text
, _mmsg_metadata :: MandrillVars
, _mmsg_recipient_metadata :: [MandrillMetadata]
, _mmsg_attachments :: [MandrillWebContent]
, _mmsg_images :: [MandrillWebContent]
} deriving Show
makeLenses ''MandrillMessage
deriveJSON defaultOptions { fieldLabelModifier = drop 6 } ''MandrillMessage
instance Arbitrary MandrillMessage where
arbitrary = MandrillMessage <$> arbitrary
<*> pure Nothing
<*> pure "Test Subject"
<*> pure (fromJust $ emailAddress "sender@example.com")
<*> pure Nothing
<*> resize 2 arbitrary
<*> pure emptyObject
<*> pure Nothing
<*> pure Nothing
<*> pure Nothing
<*> pure Nothing
<*> pure Nothing
<*> pure Nothing
<*> pure Nothing
<*> pure Nothing
<*> pure Nothing
<*> pure Nothing
<*> pure Nothing
<*> pure Nothing
<*> pure Nothing
<*> pure Nothing
<*> pure []
<*> pure []
<*> pure []
<*> pure Nothing
<*> pure []
<*> pure Nothing
<*> pure emptyObject
<*> pure []
<*> pure []
<*> pure []
type MandrillKey = T.Text
newtype MandrillDate = MandrillDate {
fromMandrillDate :: UTCTime
} deriving Show
instance ToJSON MandrillDate where
toJSON = toJSON . fromMandrillDate
instance FromJSON MandrillDate where
parseJSON = withText "MandrillDate" $ \t ->
case timeParse defaultTimeLocale "%Y-%m-%d %I:%M:%S%Q" (T.unpack t) of
Just d -> pure $ MandrillDate d
_ -> fail "could not parse Mandrill date"