diff --git a/mandrill.cabal b/mandrill.cabal --- a/mandrill.cabal +++ b/mandrill.cabal @@ -1,5 +1,5 @@ name: mandrill -version: 0.1.1.0 +version: 0.5.8.0 synopsis: Library for interfacing with the Mandrill JSON API description: Pure Haskell client for the Mandrill JSON API license: MIT @@ -8,7 +8,7 @@ maintainer: alfredo.dinapoli@gmail.com category: Network build-type: Simple -tested-with: GHC == 7.4, GHC == 7.6, GHC == 7.8 +tested-with: GHC == 7.4, GHC == 7.6, GHC == 7.8, GHC == 7.10.2 cabal-version: >=1.10 source-repository head @@ -25,32 +25,36 @@ Network.API.Mandrill.Users.Types Network.API.Mandrill.Messages Network.API.Mandrill.Messages.Types + Network.API.Mandrill.Inbound + Network.API.Mandrill.Webhooks + Network.API.Mandrill.Senders other-modules: Network.API.Mandrill.Utils Network.API.Mandrill.HTTP - Network.API.Mandrill.Orphans -- other-extensions: build-depends: base >=4.6 && < 5 , containers >= 0.5.0.0 , bytestring >= 0.9.0 , base64-bytestring >= 1.0.0.1 - , text >= 1.0.0.0 && < 1.3 + , text >= 1.0.0.0 && < 2.2 , http-types >= 0.8.0 , http-client >= 0.3.0 , http-client-tls >= 0.2.0.0 - , aeson >= 0.7.0.3 && < 0.9 - , lens >= 4.0 + , aeson >= 0.7.0.3 && < 3 + , microlens-th >= 0.4.0.0 , blaze-html >= 0.5.0.0 - , QuickCheck >= 2.6 && < 2.8 + , QuickCheck >= 2.6 && < 3.0 , mtl < 3.0 , time , email-validate >= 1.0.0 , old-locale + , unordered-containers hs-source-dirs: src default-language: Haskell2010 + ghc-options: -funbox-strict-fields diff --git a/src/Network/API/Mandrill.hs b/src/Network/API/Mandrill.hs --- a/src/Network/API/Mandrill.hs +++ b/src/Network/API/Mandrill.hs @@ -9,27 +9,30 @@ module Network.API.Mandrill ( module M , sendEmail + , sendTextEmail , emptyMessage , newTextMessage , newHtmlMessage + , newTemplateMessage + , newTemplateMessage' , liftIO -- * Appendix: Example Usage -- $exampleusage ) where -import Control.Monad.Reader -import Control.Lens -import Data.Time -import Text.Blaze.Html -import Network.API.Mandrill.Types as M -import Network.API.Mandrill.Messages as M -import Network.API.Mandrill.Messages.Types as M -import Network.API.Mandrill.Trans as M -import Data.Monoid -import Text.Email.Validate -import qualified Data.Text as T -import qualified Data.Aeson as JSON +import Control.Monad.Reader +import qualified Data.Aeson as JSON +import qualified Data.HashMap.Strict as H +import Data.Monoid +import qualified Data.Text as T +import Data.Time +import Network.API.Mandrill.Messages as M +import Network.API.Mandrill.Messages.Types as M +import Network.API.Mandrill.Trans as M +import Network.API.Mandrill.Types as M +import Text.Blaze.Html +import Text.Email.Validate {- $exampleusage @@ -38,7 +41,7 @@ > {-# LANGUAGE OverloadedStrings #-} > import Text.Email.Validate > import Network.API.Mandrill -> +> > main :: IO () > main = do > case validate "foo@example.com" of @@ -56,15 +59,15 @@ -- | Builds an empty message, given only the email of the sender and -- the emails of the receiver. Please note that the "Subject" will be empty, -- so you need to use either @newTextMessage@ or @newHtmlMessage@ to populate it. -emptyMessage :: EmailAddress -> [EmailAddress] -> MandrillMessage +emptyMessage :: Maybe EmailAddress -> [EmailAddress] -> MandrillMessage emptyMessage f t = MandrillMessage { _mmsg_html = mempty , _mmsg_text = Nothing - , _mmsg_subject = T.empty - , _mmsg_from_email = f + , _mmsg_subject = Nothing + , _mmsg_from_email = MandrillEmail <$> f , _mmsg_from_name = Nothing , _mmsg_to = map newRecipient t - , _mmsg_headers = JSON.Null + , _mmsg_headers = mempty , _mmsg_important = Nothing , _mmsg_track_opens = Nothing , _mmsg_track_clicks = Nothing @@ -85,7 +88,7 @@ , _mmsg_subaccount = Nothing , _mmsg_google_analytics_domains = [] , _mmsg_google_analytics_campaign = Nothing - , _mmsg_metadata = JSON.Null + , _mmsg_metadata = mempty , _mmsg_recipient_metadata = [] , _mmsg_attachments = [] , _mmsg_images = [] @@ -104,10 +107,29 @@ -- ^ The HTML body -> MandrillMessage newHtmlMessage f t subj html = let body = mkMandrillHtml html in - ((mmsg_html .~ body) . (mmsg_subject .~ subj)) $ (emptyMessage f t) + (emptyMessage (Just f) t) { _mmsg_html = body, _mmsg_subject = Just subj } +-------------------------------------------------------------------------------- +-- | Create a new template message (no HTML). +newTemplateMessage :: EmailAddress + -- ^ Sender email + -> [EmailAddress] + -- ^ Receivers email + -> T.Text + -- ^ Subject + -> MandrillMessage +newTemplateMessage f t subj = (emptyMessage (Just f) t) { _mmsg_subject = Just subj } -------------------------------------------------------------------------------- +-- | Create a new template message (no HTML) with recipient addresses only. +-- This function is preferred when the template being used has the sender +-- address and subject already configured in the Mandrill server. +newTemplateMessage' :: [EmailAddress] + -- ^ Receivers email + -> MandrillMessage +newTemplateMessage' = emptyMessage Nothing + +-------------------------------------------------------------------------------- -- | Create a new textual message. By default Mandrill doesn't require you -- to specify the @mmsg_text@ when sending out the JSON Payload, and this -- function ensure it will be present. @@ -121,9 +143,11 @@ -- ^ The body, as normal text. -> MandrillMessage newTextMessage f t subj txt = let body = unsafeMkMandrillHtml txt in - ((mmsg_html .~ body) . - (mmsg_text .~ Just txt) . - (mmsg_subject .~ subj)) (emptyMessage f t) + (emptyMessage (Just f) t) { + _mmsg_html = body + , _mmsg_text = Just txt + , _mmsg_subject = Just subj + } -------------------------------------------------------------------------------- @@ -131,7 +155,7 @@ -- 'MandrillMessage' and this function will send an email inside a -- 'MandrillT' transformer. You are not forced to use the 'MandrillT' context -- though. Have a look at "Network.API.Mandrill.Messages" for an IO-based, --- low lever function for sending email. +-- low level function for sending email. sendEmail :: MonadIO m => MandrillMessage -> MandrillT m (MandrillResponse [MessagesResponse]) diff --git a/src/Network/API/Mandrill/HTTP.hs b/src/Network/API/Mandrill/HTTP.hs --- a/src/Network/API/Mandrill/HTTP.hs +++ b/src/Network/API/Mandrill/HTTP.hs @@ -1,15 +1,15 @@ {-# LANGUAGE OverloadedStrings #-} module Network.API.Mandrill.HTTP where -import Network.API.Mandrill.Settings -import Network.API.Mandrill.Types -import qualified Data.Text as T -import Data.Monoid -import Data.Aeson -import Control.Applicative -import Network.HTTP.Types -import Network.HTTP.Client -import Network.HTTP.Client.TLS +import Control.Applicative +import Data.Aeson +import Data.Monoid +import qualified Data.Text as T +import Network.API.Mandrill.Settings +import Network.API.Mandrill.Types +import Network.HTTP.Client +import Network.HTTP.Client.TLS +import Network.HTTP.Types toMandrillResponse :: (MandrillEndpoint ep, FromJSON a, ToJSON rq) => ep @@ -18,7 +18,7 @@ -> IO (MandrillResponse a) toMandrillResponse ep rq mbMgr = do let fullUrl = mandrillUrl <> toUrl ep - rq' <- parseUrl (T.unpack fullUrl) + rq' <- parseRequest (T.unpack fullUrl) let headers = [(hContentType, "application/json")] let jsonBody = encode rq let req = rq' { diff --git a/src/Network/API/Mandrill/Inbound.hs b/src/Network/API/Mandrill/Inbound.hs new file mode 100644 --- /dev/null +++ b/src/Network/API/Mandrill/Inbound.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE TemplateHaskell #-} +module Network.API.Mandrill.Inbound where +import Data.Aeson (FromJSON, ToJSON, parseJSON, + toJSON) +import Data.Aeson.TH (defaultOptions, deriveJSON) +import Data.Aeson.Types (fieldLabelModifier) +import Data.Text (Text) +import Lens.Micro.TH (makeLenses) +import Network.API.Mandrill.HTTP (toMandrillResponse) +import Network.API.Mandrill.Settings +import Network.API.Mandrill.Types +import Network.HTTP.Client (Manager) + +data DomainAddRq = + DomainAddRq + { _darq_key :: MandrillKey + , _darq_domain :: Text + } deriving Show + +makeLenses ''DomainAddRq +deriveJSON defaultOptions { fieldLabelModifier = drop 6 } ''DomainAddRq + +data DomainAddResponse = + DomainAddResponse + { _dares_domain :: Text + , _dares_created_at :: MandrillDate + , _dares_valid_mx :: Bool + } deriving Show + + + +makeLenses ''DomainAddResponse +deriveJSON defaultOptions { fieldLabelModifier = drop 7 } ''DomainAddResponse + +data RouteAddResponse = + RouteAddResponse + { _rares_id :: Text + , _rares_pattern :: Text + , _rares_url :: Text + } deriving Show + + + +makeLenses ''RouteAddResponse +deriveJSON defaultOptions { fieldLabelModifier = drop 7 } ''RouteAddResponse + +data RouteAddRq = + RouteAddRq + { _rarq_key :: Text + , _rarq_domain :: Text + , _rarq_pattern :: Text + , _rarq_url :: Text + } deriving Show + +makeLenses ''RouteAddRq +deriveJSON defaultOptions { fieldLabelModifier = drop 6 } ''RouteAddRq + +addDomain :: MandrillKey + -- ^ The API key + -> Text + -- ^ The domain to add + -> Maybe Manager + -> IO (MandrillResponse DomainAddResponse) +addDomain k dom = toMandrillResponse DomainsAdd (DomainAddRq k dom) + + + +addRoute :: MandrillKey + -- ^ The API key + -> Text + -- ^ The domain to add + -> Text + -- ^ the pattern including wildcards + -> Text + -- ^ URL to forward to + -> Maybe Manager + -> IO (MandrillResponse RouteAddResponse) +addRoute k dom pattern forward = toMandrillResponse RoutesAdd (RouteAddRq k dom pattern forward) diff --git a/src/Network/API/Mandrill/Messages.hs b/src/Network/API/Mandrill/Messages.hs --- a/src/Network/API/Mandrill/Messages.hs +++ b/src/Network/API/Mandrill/Messages.hs @@ -1,13 +1,13 @@ module Network.API.Mandrill.Messages where -import Network.API.Mandrill.Types +import qualified Data.Text as T +import Data.Time +import Network.API.Mandrill.HTTP import Network.API.Mandrill.Messages.Types import Network.API.Mandrill.Settings -import Network.API.Mandrill.HTTP +import Network.API.Mandrill.Types import Network.HTTP.Client -import Data.Time -import qualified Data.Text as T -------------------------------------------------------------------------------- -- | Send a new transactional message through Mandrill @@ -24,3 +24,22 @@ -> Maybe Manager -> IO (MandrillResponse [MessagesResponse]) send k msg async ip_pool send_at = toMandrillResponse MessagesSend (MessagesSendRq k msg async ip_pool send_at) + +-- | Send a new transactional message through Mandrill using a template +sendTemplate :: MandrillKey + -- ^ The API key + -> MandrillTemplate + -- ^ The template name + -> [MandrillTemplateContent] + -- ^ Template content for 'editable regions' + -> MandrillMessage + -- ^ The email message + -> Maybe Bool + -- ^ Enable a background sending mode that is optimized for bulk sending + -> Maybe T.Text + -- ^ ip_pool + -> Maybe UTCTime + -- ^ send_at + -> Maybe Manager + -> IO (MandrillResponse [MessagesResponse]) +sendTemplate k template content msg async ip_pool send_at = toMandrillResponse MessagesSendTemplate (MessagesSendTemplateRq k template content msg async ip_pool send_at) diff --git a/src/Network/API/Mandrill/Messages/Types.hs b/src/Network/API/Mandrill/Messages/Types.hs --- a/src/Network/API/Mandrill/Messages/Types.hs +++ b/src/Network/API/Mandrill/Messages/Types.hs @@ -5,12 +5,12 @@ import Data.Char import Data.Time import qualified Data.Text as T -import Control.Lens import Control.Monad import Data.Monoid import Data.Aeson import Data.Aeson.Types import Data.Aeson.TH +import Lens.Micro.TH (makeLenses) import Network.API.Mandrill.Types @@ -27,6 +27,19 @@ makeLenses ''MessagesSendRq deriveJSON defaultOptions { fieldLabelModifier = drop 6 } ''MessagesSendRq +-------------------------------------------------------------------------------- +data MessagesSendTemplateRq = MessagesSendTemplateRq { + _mstrq_key :: MandrillKey + , _mstrq_template_name :: T.Text + , _mstrq_template_content :: [MandrillTemplateContent] + , _mstrq_message :: MandrillMessage + , _mstrq_async :: Maybe Bool + , _mstrq_ip_pool :: Maybe T.Text + , _mstrq_send_at :: Maybe UTCTime + } deriving Show + +makeLenses ''MessagesSendTemplateRq +deriveJSON defaultOptions { fieldLabelModifier = drop 7 } ''MessagesSendTemplateRq -------------------------------------------------------------------------------- data MessagesResponse = MessagesResponse { diff --git a/src/Network/API/Mandrill/Orphans.hs b/src/Network/API/Mandrill/Orphans.hs deleted file mode 100644 --- a/src/Network/API/Mandrill/Orphans.hs +++ /dev/null @@ -1,17 +0,0 @@ - -module Network.API.Mandrill.Orphans where - -import Data.Aeson -import Data.Aeson.Types -import Text.Email.Validate -import qualified Data.Text.Encoding as TE - - -instance ToJSON EmailAddress where - toJSON = String . TE.decodeUtf8 . toByteString - -instance FromJSON EmailAddress where - parseJSON (String s) = case validate (TE.encodeUtf8 s) of - Left err -> fail err - Right v -> return v - parseJSON o = typeMismatch "Expecting a String for EmailAddress." o diff --git a/src/Network/API/Mandrill/Senders.hs b/src/Network/API/Mandrill/Senders.hs new file mode 100644 --- /dev/null +++ b/src/Network/API/Mandrill/Senders.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE TemplateHaskell #-} +module Network.API.Mandrill.Senders where +import Data.Aeson (FromJSON, ToJSON, parseJSON, + toJSON) +import Data.Aeson.TH (defaultOptions, deriveJSON) +import Data.Aeson.Types (Value (..), fieldLabelModifier) +import Data.Text (Text) +import Data.Text.Encoding (decodeUtf8, encodeUtf8) +import Lens.Micro.TH (makeLenses) +import Network.API.Mandrill.HTTP (toMandrillResponse) +import Network.API.Mandrill.Settings +import Network.API.Mandrill.Types +import Network.HTTP.Client (Manager) +import qualified Text.Email.Validate as TEV + +data VerifyDomainRq = + VerifyDomainRq + { _vdrq_key :: MandrillKey + , _vdrq_domain :: Text + , _vdrq_mailbox :: Text + } deriving Show + +makeLenses ''VerifyDomainRq +deriveJSON defaultOptions { fieldLabelModifier = drop 6 } ''VerifyDomainRq + +data VerifyDomainResponse = + VerifyDomainResponse + { _vdres_status :: Text + , _vdres_domain :: Text + , _vdres_email :: MandrillEmail + } deriving Show + +makeLenses ''VerifyDomainResponse +deriveJSON defaultOptions { fieldLabelModifier = drop 7 } ''VerifyDomainResponse + + +verifyDomain :: MandrillKey + -- ^ The API key + -> TEV.EmailAddress + -- ^ Email address to use for verification + -> Maybe Manager + -> IO (MandrillResponse VerifyDomainResponse) +verifyDomain k email = + toMandrillResponse VerifyDomain + (VerifyDomainRq k (decodeUtf8 $ TEV.domainPart email) (decodeUtf8 $ TEV.localPart email)) diff --git a/src/Network/API/Mandrill/Settings.hs b/src/Network/API/Mandrill/Settings.hs --- a/src/Network/API/Mandrill/Settings.hs +++ b/src/Network/API/Mandrill/Settings.hs @@ -15,16 +15,26 @@ -- Messages API | MessagesSend | MessagesSendTemplate - | MessagesSearch deriving Show + | MessagesSearch + -- Inbound API + | RoutesAdd + | DomainsAdd + -- Senders API + | VerifyDomain + deriving Show + class MandrillEndpoint ep where toUrl :: ep -> T.Text instance MandrillEndpoint MandrillCalls where - toUrl UsersInfo = "users/info.json" - toUrl UsersPing = "users/ping.json" - toUrl UsersPing2 = "users/ping2.json" - toUrl UsersSenders = "users/senders.json" - toUrl MessagesSend = "messages/send.json" + toUrl UsersInfo = "users/info.json" + toUrl UsersPing = "users/ping.json" + toUrl UsersPing2 = "users/ping2.json" + toUrl UsersSenders = "users/senders.json" + toUrl MessagesSend = "messages/send.json" toUrl MessagesSendTemplate = "messages/send-template.json" - toUrl MessagesSearch = "messages/search.json" + toUrl MessagesSearch = "messages/search.json" + toUrl DomainsAdd = "inbound/add-domain.json" + toUrl RoutesAdd = "inbound/add-route.json" + toUrl VerifyDomain = "senders/verify-domain.json" diff --git a/src/Network/API/Mandrill/Types.hs b/src/Network/API/Mandrill/Types.hs --- a/src/Network/API/Mandrill/Types.hs +++ b/src/Network/API/Mandrill/Types.hs @@ -1,39 +1,59 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} module Network.API.Mandrill.Types where -import Network.API.Mandrill.Utils -import Network.API.Mandrill.Orphans() -import Test.QuickCheck -import Text.Email.Validate +import Control.Applicative +import Control.Monad (mzero) 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 Lens.Micro.TH (makeLenses) +import Network.API.Mandrill.Utils +import Test.QuickCheck +import Text.Email.Validate +#if MIN_VERSION_time(1,5,0) +import Data.Time.Format (TimeLocale, defaultTimeLocale) +#else +import System.Locale (TimeLocale, defaultTimeLocale) +#endif import Data.Aeson -import Data.Aeson.Types import Data.Aeson.TH -import qualified Text.Blaze.Html as Blaze +import Data.Aeson.Types +import qualified Data.ByteString as B +import qualified Data.ByteString.Base64 as Base64 +#if !MIN_VERSION_base(4,8,0) +import Data.Foldable +import Data.Traversable +#endif +import qualified Data.HashMap.Strict as H +import Data.Monoid +import qualified Data.Text as T +import qualified Data.Text.Encoding as TL +import qualified Data.Text.Lazy as TL +import qualified Text.Blaze.Html as Blaze import qualified Text.Blaze.Html.Renderer.Text as Blaze +import qualified Text.Email.Validate as TEV +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_status :: !T.Text + , _merr_code :: !Int + , _merr_name :: !T.Text , _merr_message :: !T.Text - } deriving Show + } deriving (Show, Eq) makeLenses ''MandrillError deriveJSON defaultOptions { fieldLabelModifier = drop 6 } ''MandrillError @@ -58,6 +78,7 @@ | RR_InvalidSender | RR_Invalid | RR_TestModeLimit + | RR_Unsigned | RR_Rule deriving Show deriveJSON defaultOptions { @@ -70,7 +91,7 @@ -- which can be either a success or a failure. data MandrillResponse k = MandrillSuccess k - | MandrillFailure MandrillError deriving Show + | MandrillFailure MandrillError deriving (Show, Eq, Functor, Foldable, Traversable) instance FromJSON k => FromJSON (MandrillResponse k) where parseJSON v = case (parseMaybe parseJSON v) :: Maybe k of @@ -89,13 +110,26 @@ -------------------------------------------------------------------------------- +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 :: EmailAddress + _mrec_email :: MandrillEmail -- ^ The email address of the recipient - , _mrec_name :: Maybe T.Text + , _mrec_name :: Maybe T.Text -- ^ The optional display name to use for the recipient - , _mrec_type :: Maybe MandrillRecipientTag + , _mrec_type :: Maybe MandrillRecipientTag -- ^ The header type to use for the recipient. -- defaults to "to" if not provided } deriving Show @@ -104,11 +138,11 @@ deriveJSON defaultOptions { fieldLabelModifier = drop 6 } ''MandrillRecipient newRecipient :: EmailAddress -> MandrillRecipient -newRecipient email = MandrillRecipient email Nothing Nothing +newRecipient email = MandrillRecipient (MandrillEmail email) Nothing Nothing instance Arbitrary MandrillRecipient where arbitrary = pure MandrillRecipient { - _mrec_email = fromJust (emailAddress "test@example.com") + _mrec_email = MandrillEmail $ fromJust (emailAddress "test@example.com") , _mrec_name = Nothing , _mrec_type = Nothing } @@ -124,6 +158,11 @@ mkMandrillHtml :: Blaze.Html -> MandrillHtml mkMandrillHtml = MandrillHtml +#if MIN_VERSION_base(4,11,0) +instance Semigroup MandrillHtml where + MandrillHtml m1 <> MandrillHtml m2 = MandrillHtml (m1 <> m2) +#endif + instance Monoid MandrillHtml where mempty = MandrillHtml mempty mappend (MandrillHtml m1) (MandrillHtml m2) = MandrillHtml (m1 <> m2) @@ -135,7 +174,7 @@ toJSON (MandrillHtml h) = String . TL.toStrict . Blaze.renderHtml $ h instance FromJSON MandrillHtml where - parseJSON (String h) = return $ MandrillHtml (Blaze.toHtml h) + parseJSON (String h) = return $ MandrillHtml (Blaze.preEscapedToHtml h) parseJSON v = typeMismatch "Expecting a String for MandrillHtml" v instance Arbitrary MandrillHtml where @@ -146,17 +185,23 @@ -------------------------------------------------------------------------------- -type MandrillHeaders = Value +type MandrillHeaders = Object -------------------------------------------------------------------------------- -type MandrillVars = Value +data MergeVar = MergeVar { + _mv_name :: !T.Text + , _mv_content :: Value + } deriving Show +makeLenses ''MergeVar +deriveJSON defaultOptions { fieldLabelModifier = drop 4 } ''MergeVar + -------------------------------------------------------------------------------- data MandrillMergeVars = MandrillMergeVars { _mmvr_rcpt :: !T.Text - , _mmvr_vars :: [MandrillVars] + , _mmvr_vars :: [MergeVar] } deriving Show makeLenses ''MandrillMergeVars @@ -164,29 +209,33 @@ -------------------------------------------------------------------------------- data MandrillMetadata = MandrillMetadata { - _mmdt_rcpt :: !T.Text - , _mmdt_values :: MandrillVars + _mmdt_rcpt :: !T.Text + , _mmdt_values :: Object } deriving Show makeLenses ''MandrillMetadata deriveJSON defaultOptions { fieldLabelModifier = drop 6 } ''MandrillMetadata -newtype Base64ByteString = B64BS B.ByteString deriving Show +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 (B64BS bs) = String . TL.decodeUtf8 . Base64.encode $ bs + toJSON (PlainBS bs) = String . TL.decodeUtf8 . Base64.encode $ bs + toJSON (EncodedB64BS bs) = String . TL.decodeUtf8 $ 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 (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 + _mwct_type :: !T.Text + , _mwct_name :: !T.Text -- ^ [for images] the Content ID of the image -- - use to reference the image -- in your HTML content @@ -199,67 +248,67 @@ -------------------------------------------------------------------------------- -- | The information on the message to send data MandrillMessage = MandrillMessage { - _mmsg_html :: MandrillHtml + _mmsg_html :: MandrillHtml -- ^ The full HTML content to be sent - , _mmsg_text :: Maybe T.Text + , _mmsg_text :: Maybe T.Text -- ^ Optional full text content to be sent - , _mmsg_subject :: !T.Text + , _mmsg_subject :: !(Maybe T.Text) -- ^ The message subject - , _mmsg_from_email :: EmailAddress + , _mmsg_from_email :: Maybe MandrillEmail -- ^ The sender email address - , _mmsg_from_name :: Maybe T.Text + , _mmsg_from_name :: Maybe T.Text -- ^ Optional from name to be used - , _mmsg_to :: [MandrillRecipient] + , _mmsg_to :: [MandrillRecipient] -- ^ A list of recipient information - , _mmsg_headers :: MandrillHeaders + , _mmsg_headers :: MandrillHeaders -- ^ optional extra headers to add to the message (most headers are allowed) - , _mmsg_important :: Maybe Bool + , _mmsg_important :: Maybe Bool -- ^ whether or not this message is important, and should be delivered ahead -- of non-important messages - , _mmsg_track_opens :: Maybe Bool + , _mmsg_track_opens :: Maybe Bool -- ^ whether or not to turn on open tracking for the message - , _mmsg_track_clicks :: Maybe Bool + , _mmsg_track_clicks :: Maybe Bool -- ^ whether or not to turn on click tracking for the message - , _mmsg_auto_text :: Maybe Bool + , _mmsg_auto_text :: Maybe Bool -- ^ whether or not to automatically generate a text part for messages that are not given text - , _mmsg_auto_html :: Maybe Bool + , _mmsg_auto_html :: Maybe Bool -- ^ whether or not to automatically generate an HTML part for messages that are not given HTML - , _mmsg_inline_css :: Maybe Bool + , _mmsg_inline_css :: Maybe Bool -- ^ whether or not to automatically inline all CSS styles provided in the message HTML -- - only for HTML documents less than 256KB in size - , _mmsg_url_strip_qs :: Maybe Bool + , _mmsg_url_strip_qs :: Maybe Bool -- ^ whether or not to strip the query string from URLs when aggregating tracked URL data - , _mmsg_preserve_recipients :: Maybe Bool + , _mmsg_preserve_recipients :: Maybe Bool -- ^ whether or not to expose all recipients in to "To" header for each email - , _mmsg_view_content_link :: Maybe Bool + , _mmsg_view_content_link :: Maybe Bool -- ^ set to false to remove content logging for sensitive emails - , _mmsg_bcc_address :: Maybe T.Text + , _mmsg_bcc_address :: Maybe T.Text -- ^ an optional address to receive an exact copy of each recipient's email - , _mmsg_tracking_domain :: Maybe T.Text + , _mmsg_tracking_domain :: Maybe T.Text -- ^ a custom domain to use for tracking opens and clicks instead of mandrillapp.com - , _mmsg_signing_domain :: Maybe Bool - -- ^ a custom domain to use for SPF/DKIM signing instead of mandrill + , _mmsg_signing_domain :: Maybe Bool + -- ^ a custom domain to use for SPF/DKIM signing instead of mandrill -- (for "via" or "on behalf of" in email clients) - , _mmsg_return_path_domain :: Maybe Bool + , _mmsg_return_path_domain :: Maybe Bool -- ^ a custom domain to use for the messages's return-path - , _mmsg_merge :: Maybe Bool + , _mmsg_merge :: Maybe Bool -- ^ whether to evaluate merge tags in the message. -- Will automatically be set to true if either merge_vars -- or global_merge_vars are provided. - , _mmsg_global_merge_vars :: [MandrillVars] + , _mmsg_global_merge_vars :: [MergeVar] -- ^ global merge variables to use for all recipients. You can override these per recipient. - , _mmsg_merge_vars :: [MandrillMergeVars] + , _mmsg_merge_vars :: [MandrillMergeVars] -- ^ per-recipient merge variables, which override global merge variables with the same name. - , _mmsg_tags :: [MandrillTags] + , _mmsg_tags :: [MandrillTags] -- ^ an array of string to tag the message with. Stats are accumulated using tags, -- though we only store the first 100 we see, so this should not be unique -- or change frequently. Tags should be 50 characters or less. -- Any tags starting with an underscore are reserved for internal use -- and will cause errors. - , _mmsg_subaccount :: Maybe T.Text + , _mmsg_subaccount :: Maybe T.Text -- ^ the unique id of a subaccount for this message -- - must already exist or will fail with an error - , _mmsg_google_analytics_domains :: [T.Text] + , _mmsg_google_analytics_domains :: [T.Text] -- ^ an array of strings indicating for which any matching URLs -- will automatically have Google Analytics parameters appended -- to their query string automatically. @@ -267,17 +316,17 @@ -- ^ optional string indicating the value to set for the utm_campaign -- tracking parameter. If this isn't provided the email's from address -- will be used instead. - , _mmsg_metadata :: MandrillVars + , _mmsg_metadata :: Object -- ^ metadata an associative array of user metadata. Mandrill will store -- this metadata and make it available for retrieval. -- In addition, you can select up to 10 metadata fields to index -- and make searchable using the Mandrill search api. - , _mmsg_recipient_metadata :: [MandrillMetadata] + , _mmsg_recipient_metadata :: [MandrillMetadata] -- ^ Per-recipient metadata that will override the global values -- specified in the metadata parameter. - , _mmsg_attachments :: [MandrillWebContent] + , _mmsg_attachments :: [MandrillWebContent] -- ^ an array of supported attachments to add to the message - , _mmsg_images :: [MandrillWebContent] + , _mmsg_images :: [MandrillWebContent] -- ^ an array of embedded images to add to the message } deriving Show @@ -287,11 +336,11 @@ instance Arbitrary MandrillMessage where arbitrary = MandrillMessage <$> arbitrary <*> pure Nothing - <*> pure "Test Subject" - <*> pure (fromJust $ emailAddress "sender@example.com") + <*> pure (Just "Test Subject") + <*> pure (MandrillEmail <$> emailAddress "sender@example.com") <*> pure Nothing <*> resize 2 arbitrary - <*> pure emptyObject + <*> pure mempty <*> pure Nothing <*> pure Nothing <*> pure Nothing @@ -312,13 +361,24 @@ <*> pure Nothing <*> pure [] <*> pure Nothing - <*> pure emptyObject + <*> pure mempty <*> pure [] <*> pure [] <*> pure [] -------------------------------------------------------------------------------- +-- | Key value pair for replacing content in templates via 'Editable Regions' +data MandrillTemplateContent = MandrillTemplateContent { + _mtc_name :: T.Text + , _mtc_content :: T.Text + } deriving Show + +makeLenses ''MandrillTemplateContent +deriveJSON defaultOptions { fieldLabelModifier = drop 5 } ''MandrillTemplateContent + +-------------------------------------------------------------------------------- type MandrillKey = T.Text +type MandrillTemplate = T.Text newtype MandrillDate = MandrillDate { fromMandrillDate :: UTCTime @@ -329,6 +389,6 @@ instance FromJSON MandrillDate where parseJSON = withText "MandrillDate" $ \t -> - case parseTime defaultTimeLocale "%Y-%m-%d %I:%M:%S%Q" (T.unpack t) of + case timeParse defaultTimeLocale "%Y-%m-%d %H:%M:%S%Q" (T.unpack t) of Just d -> pure $ MandrillDate d _ -> fail "could not parse Mandrill date" diff --git a/src/Network/API/Mandrill/Users/Types.hs b/src/Network/API/Mandrill/Users/Types.hs --- a/src/Network/API/Mandrill/Users/Types.hs +++ b/src/Network/API/Mandrill/Users/Types.hs @@ -5,12 +5,12 @@ import Data.Char import Data.Time import qualified Data.Text as T -import Control.Lens import Control.Monad import Data.Monoid import Data.Aeson import Data.Aeson.Types import Data.Aeson.TH +import Lens.Micro.TH (makeLenses) import Network.API.Mandrill.Types diff --git a/src/Network/API/Mandrill/Webhooks.hs b/src/Network/API/Mandrill/Webhooks.hs new file mode 100644 --- /dev/null +++ b/src/Network/API/Mandrill/Webhooks.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +module Network.API.Mandrill.Webhooks where +import Control.Applicative (pure) +import Control.Monad (mzero) +import Data.Aeson (FromJSON, ToJSON, parseJSON, + toJSON) +import Data.Aeson (Value (String)) +import Data.Aeson.TH (defaultOptions, deriveJSON) +import Data.Aeson.Types (fieldLabelModifier) +import Data.Set (Set) +import Data.Text (Text) +import qualified Data.Text as T +import Lens.Micro.TH (makeLenses) +import Network.API.Mandrill.HTTP (toMandrillResponse) +import Network.API.Mandrill.Settings +import Network.API.Mandrill.Types +import Network.HTTP.Client (Manager) + +data EventHook + = EventSent + | EventDeferred + | EventHardBounced + | EventSoftBounced + | EventOpened + | EventClicked + | EventMarkedAsSpam + | EventUnsubscribed + | EventRejected + deriving (Ord,Eq) + +instance Show EventHook where + show e = case e of + EventSent -> "send" + EventDeferred -> "deferral" + EventSoftBounced -> "soft_bounce" + EventHardBounced -> "hard_bounce" + EventOpened -> "open" + EventClicked -> "click" + EventMarkedAsSpam -> "spam" + EventUnsubscribed -> "unsub" + EventRejected -> "reject" +instance FromJSON EventHook where + parseJSON (String s) = + case s of + "send" -> pure EventSent + "deferral" -> pure EventDeferred + "soft_bounce" -> pure EventSoftBounced + "hard_bounce" -> pure EventHardBounced + "open" -> pure EventOpened + "click" -> pure EventClicked + "spam" -> pure EventMarkedAsSpam + "reject" -> pure EventRejected + "unsub" -> pure EventUnsubscribed + x -> fail ("can't parse " ++ show x) + + +instance ToJSON EventHook where + toJSON e = String (T.pack $ show e) + +data WebhookAddRq = + WebhookAddRq + { _warq_key :: MandrillKey + , _warq_url :: Text + , _warq_description :: Text + , _warq_events :: Set EventHook + } deriving Show + +makeLenses ''WebhookAddRq +deriveJSON defaultOptions { fieldLabelModifier = drop 6 } ''WebhookAddRq diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,14 +1,14 @@ {-# LANGUAGE OverloadedStrings #-} module Main where -import System.Environment import Data.Monoid -import Tests +import qualified Data.Text as T import Online +import System.Environment import Test.Tasty import Test.Tasty.HUnit import Test.Tasty.QuickCheck -import qualified Data.Text as T +import Tests ---------------------------------------------------------------------- withQuickCheckDepth :: TestName -> Int -> [TestTree] -> TestTree @@ -23,10 +23,12 @@ Nothing -> return [] Just k -> return [ testGroup "Mandrill online tests" [ - testCase "users/info.json" (testOnlineUsersInfo k) - , testCase "users/ping2.json" (testOnlineUsersPing2 k) - , testCase "users/senders.json" (testOnlineUsersSenders k) - , testCase "messages/send.json" (testOnlineMessagesSend k) + testCase "users/info.json" (testOnlineUsersInfo k) + , testCase "users/ping2.json" (testOnlineUsersPing2 k) + , testCase "users/senders.json" (testOnlineUsersSenders k) + , testCase "messages/send.json" (testOnlineMessagesSend k) + , testCase "inbound/addDomain.json" (testOnlineDomainAdd k) + , testCase "inbound/addRoute.json" (testOnlineRouteAdd k) ]] ---------------------------------------------------------------------- @@ -39,5 +41,10 @@ testCase "users/info.json API parsing" testUsersInfo , testCase "users/senders.json API parsing" testUsersSenders , testCase "messages/send.json API parsing" testMessagesSend + , testCase "messages/send.json API response parsing" testMessagesResponseRejected + , testCase "inbound/add-route.json API response parsing" testRouteAdd + , testCase "inbound/add-domain.json API response parsing" testDomainAdd + , testCase "senders/verify-domain.json API response parsing" testVerifyDomain + , testCase "webhooks/add.json API response parsing" testWebhookAdd ] ] diff --git a/test/Online.hs b/test/Online.hs --- a/test/Online.hs +++ b/test/Online.hs @@ -1,19 +1,20 @@ {-# LANGUAGE OverloadedStrings #-} module Online where -import Test.QuickCheck -import Test.Tasty.HUnit -import Text.RawString.QQ -import Data.Either import Data.Aeson +import qualified Data.ByteString.Char8 as C8 +import Data.Either import Network.API.Mandrill.Messages.Types import Network.API.Mandrill.Users.Types -import qualified Data.ByteString.Char8 as C8 import RawData +import Test.QuickCheck +import Test.Tasty.HUnit +import Text.RawString.QQ +import qualified Network.API.Mandrill.Inbound as API +import qualified Network.API.Mandrill.Messages as API import Network.API.Mandrill.Types -import qualified Network.API.Mandrill.Messages as API -import qualified Network.API.Mandrill.Users as API +import qualified Network.API.Mandrill.Users as API -- -- Users calls @@ -50,3 +51,20 @@ case res of MandrillSuccess _ -> return () MandrillFailure e -> fail $ "messages/send.json " ++ show e + +-- +-- Inbound calls +-- +testOnlineDomainAdd :: MandrillKey -> Assertion +testOnlineDomainAdd k = do + res <- API.addDomain k "foobar.com" Nothing + case res of + MandrillSuccess a -> print a + MandrillFailure e -> fail $ "inbound/add-domain.json " ++ show e + +testOnlineRouteAdd :: MandrillKey -> Assertion +testOnlineRouteAdd k = do + res <- API.addRoute k "foobar.com" "mail-*" "http://requestb.in/19a4frw1" Nothing + case res of + MandrillSuccess a -> print a + MandrillFailure e -> fail $ "inbound/add-domain.json " ++ show e diff --git a/test/RawData.hs b/test/RawData.hs --- a/test/RawData.hs +++ b/test/RawData.hs @@ -1,10 +1,10 @@ {-# LANGUAGE QuasiQuotes #-} module RawData where -import Test.QuickCheck -import Test.Tasty.HUnit -import Text.RawString.QQ -import Data.Either +import Data.Either +import Test.QuickCheck +import Test.Tasty.HUnit +import Text.RawString.QQ usersInfoData :: String usersInfoData = [r| @@ -198,5 +198,60 @@ "async": false, "ip_pool": "Main Pool", "send_at": "2014-08-17T14:23:02.954Z" +} +|] + + +messagesResponseRejected = [r| +[ { "email" : "foo@bar.com", + "status" : "rejected", + "_id" : "abc123", + "reject_reason": "unsigned" + } +] +|] + + +domainAdd = [r| +{ + "domain": "inbound.example.com", + "created_at": "2013-01-01 15:30:27", + "valid_mx": true +} +|] + + +routeAdd= [r| +{ + "id": "7.23", + "pattern": "mailbox-*", + "url": "http://example.com/webhook-url" +} +|] + +domainVerify = [r| +{ + "status": "example status", + "domain": "example domain", + "email": "email@domain.com" +} +|] + +webhookAdd = [r| +{ + "key": "example key", + "url": "http://example/webhook-url", + "description": "My Example Webhook", + "events": [ + "send", + "deferral", + "hard_bounce", + "soft_bounce", + "open", + "click", + "spam", + "unsub", + "reject" + ] } |] diff --git a/test/Tests.hs b/test/Tests.hs --- a/test/Tests.hs +++ b/test/Tests.hs @@ -1,13 +1,17 @@ {-# LANGUAGE CPP #-} module Tests where -import Test.Tasty.HUnit -import Data.Either -import Data.Aeson -import Network.API.Mandrill.Messages.Types -import Network.API.Mandrill.Users.Types -import qualified Data.ByteString.Char8 as C8 -import RawData +import Data.Aeson +import qualified Data.ByteString.Char8 as C8 +import Data.Either +import Network.API.Mandrill.Inbound +import Network.API.Mandrill.Messages.Types +import Network.API.Mandrill.Senders +import Network.API.Mandrill.Types +import Network.API.Mandrill.Users.Types +import Network.API.Mandrill.Webhooks +import RawData +import Test.Tasty.HUnit #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 706 isRight :: Either a b -> Bool @@ -16,7 +20,7 @@ #endif testMessagesSend :: Assertion -testMessagesSend = +testMessagesSend = assertBool ("send.json: Parsing failed! " ++ show parsePayload) (isRight parsePayload) where @@ -40,3 +44,45 @@ where parsePayload :: Either String UsersSendersResponse parsePayload = eitherDecodeStrict . C8.pack $ usersSendersData + +testMessagesResponseRejected :: Assertion +testMessagesResponseRejected = do + assertBool ("send.json response: Parsing failed" ++ show parsePayload) + (isRight parsePayload) + where + parsePayload :: Either String (MandrillResponse [MessagesResponse]) + parsePayload = eitherDecodeStrict . C8.pack $ messagesResponseRejected + +testDomainAdd :: Assertion +testDomainAdd = + assertBool ("inbound/add-domain.json (response): parsing failed" ++ show parsePayload) + (isRight parsePayload) + where + parsePayload :: Either String DomainAddResponse + parsePayload = eitherDecodeStrict . C8.pack $ domainAdd + + +testRouteAdd :: Assertion +testRouteAdd = + assertBool ("inbound/add-route.json (response): parsing failed" ++ show parsePayload) + (isRight parsePayload) + where + parsePayload :: Either String RouteAddResponse + parsePayload = eitherDecodeStrict . C8.pack $ routeAdd + +testVerifyDomain :: Assertion +testVerifyDomain = + assertBool ("senders/verify-domain.json" ++ show parsePayload) + (isRight parsePayload) + where + parsePayload :: Either String VerifyDomainResponse + parsePayload = eitherDecodeStrict . C8.pack $ domainVerify + + +testWebhookAdd :: Assertion +testWebhookAdd = + assertBool ("webhooks/add.json (request): parsing failed" ++ show parsePayload) + (isRight parsePayload) + where + parsePayload :: Either String WebhookAddRq + parsePayload = eitherDecodeStrict . C8.pack $ webhookAdd