diff --git a/Mail/Hailgun.hs b/Mail/Hailgun.hs --- a/Mail/Hailgun.hs +++ b/Mail/Hailgun.hs @@ -1,13 +1,14 @@ -{-# LANGUAGE CPP, FlexibleContexts #-} +{-# LANGUAGE FlexibleContexts #-} -- | Hailgun is a Haskell wrapper around the that use -- type safety to ensure that you are sending a valid request to the Mailgun API's. Mailgun is a -- service that lets you send emails. It also contains a number of other email handling API's that -- will be implimented in the future. -module Mail.Hailgun +module Mail.Hailgun ( sendEmail , hailgunMessage - , HailgunMessage + , addAttachment , HailgunContext(..) + , HailgunMessage , MessageSubject , MessageContent(..) , MessageRecipients(..) @@ -22,341 +23,24 @@ , HailgunDomainResponse(..) , HailgunTime(..) , toProxy + , Attachment(..) + , AttachmentBody(..) ) where -import Control.Applicative ((<$>), (<*>), pure) -import Control.Arrow (second) -import Control.Monad (mzero) -import Control.Monad.IO.Class -import Control.Monad.Catch (MonadThrow(..)) -import Data.Aeson -import qualified Data.ByteString as B -import qualified Data.ByteString.Char8 as BC -import qualified Data.ByteString.Lazy.Char8 as BCL -import qualified Data.Text as T -import Data.Time.Clock (UTCTime(..)) -import Data.Time.LocalTime (zonedTimeToUTC) -import Text.Email.Validate -import Network.HTTP.Client (Request(..), Response(..), parseUrl, httpLbs, withManager, responseStatus, responseBody, applyBasicAuth, setQueryString, Proxy(..)) -import Network.HTTP.Client.Internal (addProxy) -import Network.HTTP.Client.MultipartFormData (Part(..), formDataBody, partBS) -import Network.HTTP.Client.TLS (tlsManagerSettings) -import qualified Network.HTTP.Types.Status as NT -import qualified Network.HTTP.Types.Method as NM - -import Data.Time.Format (ParseTime(..), parseTime) -#if MIN_VERSION_time(1,5,0) -import Data.Time.Format(defaultTimeLocale) -#else -import System.Locale (defaultTimeLocale) -#endif - -{- - - The basic rest API's look like this when used in curl: - - - - curl -s --user 'api:key-3ax6xnjp29jd6fds4gc373sgvjxteol0' \ - - https://api.mailgun.net/v2/samples.mailgun.org/messages \ - - -F from='Excited User ' \ - - -F to=baz@example.com \ - - -F to=bar@example.com \ - - -F subject='Hello' \ - - -F text='Testing some Mailgun awesomness!' - - - - This is what we need to emulate with this library. - -} - -type UnverifiedEmailAddress = B.ByteString -- ^ Represents an email address that is not yet verified. -type MessageSubject = String -- ^ Represents a message subject. - --- | Any email content that you wish to send should be encoded into these types before it is sent. --- Currently, according to the API, you should always send a Text Only part in the email and you can --- optionally add a nicely formatted HTML version of that email to the sent message. --- --- @ --- It is best to send multi-part emails using both text and HTML or text only. Sending HTML only --- email is not well received by ESPs. --- @ --- () --- --- This API mirrors that advice so that you can always get it right. -data MessageContent - -- | The Text only version of the message content. - = TextOnly - { textContent :: B.ByteString - } - -- | A message that contains both a Text version of the email content and a HTML version of the email content. - | TextAndHTML - { textContent :: B.ByteString -- ^ The text content that you wish to send (please note that many clients will take the HTML version first if it is present but that the text version is a great fallback). - , htmlContent :: B.ByteString -- ^ The HTML content that you wish to send. - } - --- | A Hailgun Email message that may be sent. It contains important information such as the address --- that the email is from, the addresses that it should be going to, the subject of the message and --- the content of the message. Any email that you wish to send via this api must be converted into --- this structure first. To create a message then please use the hailgunMessage interface. -data HailgunMessage = HailgunMessage - { messageSubject :: MessageSubject - , messageContent :: MessageContent - , messageFrom :: EmailAddress - , messageTo :: [EmailAddress] - , messageCC :: [EmailAddress] - , messageBCC :: [EmailAddress] - } - -- TODO support sending attachments in the future - -- TODO inline image support for the future - -- TODO o:tag support - -- TODO o:campaign support - -- messageDKIMSupport :: Bool TODO o:dkim support - -- TODO o:deliverytime support for up to three days in the future - -- TODO o:testmode support - -- TODO o:tracking support - -- TODO o:tracking-clicks support - -- TODO o:tracking-opens support - -- TODO custom mime header support - -- TODO custome message data support - --- | No recipients for your email. Useful singleton instance to avoid boilerplate in your code. For --- example: --- --- @ --- toBob = emptyMessageRecipients { recipientsTo = [\"bob\@bob.test\"] } --- @ -emptyMessageRecipients :: MessageRecipients -emptyMessageRecipients = MessageRecipients [] [] [] - --- | A collection of unverified email recipients separated into the To, CC and BCC groupings that --- email supports. -data MessageRecipients = MessageRecipients - { recipientsTo :: [UnverifiedEmailAddress] -- ^ The people to email directly. - , recipientsCC :: [UnverifiedEmailAddress] -- ^ The people to \"Carbon Copy\" into the email. Honestly, why is that term not deprecated yet? - , recipientsBCC :: [UnverifiedEmailAddress] -- ^ The people to \"Blind Carbon Copy\" into the email. There really needs to be a better name for this too. - } - --- | A generic error message that is returned by the Hailgun library. -type HailgunErrorMessage = String - --- | A method to construct a HailgunMessage. You require a subject, content, From address and people --- to send the email to and it will give you back a valid Hailgun email message. Or it will error --- out while trying. -hailgunMessage - :: MessageSubject -- ^ The purpose of the email surmised. - -> MessageContent -- ^ The full body of the email. - -> UnverifiedEmailAddress -- ^ The email account that the recipients should respond to in order to get back to us. - -> MessageRecipients -- ^ The people that should recieve this email. - -> Either HailgunErrorMessage HailgunMessage -- ^ Either an error while trying to create a valid message or a valid message. -hailgunMessage subject content sender recipients = do - from <- validate sender - to <- mapM validate (recipientsTo recipients) - cc <- mapM validate (recipientsCC recipients) - bcc <- mapM validate (recipientsBCC recipients) - return HailgunMessage - { messageSubject = subject - , messageContent = content - , messageFrom = from - , messageTo = to - , messageCC = cc - , messageBCC = bcc - } - -toPostVars :: HailgunMessage -> [(BC.ByteString, BC.ByteString)] -toPostVars message = - [ (BC.pack "from", toByteString . messageFrom $ message) - , (BC.pack "subject", BC.pack $ messageSubject message) - ] ++ to - ++ cc - ++ bcc - ++ fromContent (messageContent message) - where - to = convertEmails (BC.pack "to") . messageTo $ message - cc = convertEmails (BC.pack "cc") . messageCC $ message - bcc = convertEmails (BC.pack "bcc") . messageBCC $ message - - fromContent :: MessageContent -> [(BC.ByteString, BC.ByteString)] - fromContent t@(TextOnly _) = [ (BC.pack "text", textContent t) ] - fromContent th@(TextAndHTML {}) = (BC.pack "html", htmlContent th) : fromContent (TextOnly . textContent $ th) - - convertEmails :: BC.ByteString -> [EmailAddress] -> [(BC.ByteString, BC.ByteString)] - convertEmails prefix = fmap ((,) prefix . toByteString) - --- | When comunnicating to the Mailgun service you need to have some common pieces of information to --- authenticate successfully. This context encapsulates that required information. -data HailgunContext = HailgunContext - -- TODO better way to represent a domain - { hailgunDomain :: String -- ^ The domain of the mailgun account that you wish to send the emails through. - , hailgunApiKey :: String -- ^ The API key for the mailgun account so that you can successfully make requests. Please note that it should include the 'key' prefix. - , hailgunProxy :: Maybe Proxy - } - --- TODO replace with MailgunSendResponse --- | The response to an email being accepted by the Mailgun API. -data HailgunSendResponse = HailgunSendResponse - { hsrMessage :: String -- ^ The freeform message from the mailgun API. - , hsrId :: String -- ^ The ID of the message that has been accepted by the Mailgun api. - } - --- TODO make this Hailgun specific and different for the Mailgun api. That way there is the correct --- separation of concerns. --- | An error that comes from Mailgun or the Hailgun API. -data HailgunErrorResponse = HailgunErrorResponse - { herMessage :: String -- ^ A generic message describing the error. - } - -toHailgunError :: String -> HailgunErrorResponse -toHailgunError = HailgunErrorResponse - -instance FromJSON HailgunSendResponse where - parseJSON (Object v) = HailgunSendResponse - <$> v .: T.pack "message" - <*> v .: T.pack "id" - parseJSON _ = mzero - -instance FromJSON HailgunErrorResponse where - parseJSON (Object v) = HailgunErrorResponse - <$> v .: T.pack "message" - parseJSON _ = mzero - -encodeFormData :: MonadIO m => [(BC.ByteString, BC.ByteString)] -> Request -> m Request -encodeFormData fields = formDataBody (map toPart fields) - where - toPart :: (BC.ByteString, BC.ByteString) -> Part - toPart (name, content) = partBS (T.pack . BC.unpack $ name) content - --- | Send an email using the Mailgun API's. This method is capable of sending a message over the --- Mailgun service. All it needs is the appropriate context. -sendEmail - :: HailgunContext -- ^ The Mailgun context to operate in. - -> HailgunMessage -- ^ The Hailgun message to be sent. - -> IO (Either HailgunErrorResponse HailgunSendResponse) -- ^ The result of the sent email. Either a sent email or a successful send. -sendEmail context message = do - request <- postRequest url context (toPostVars message) - response <- withManager tlsManagerSettings (httpLbs request) - return $ parseResponse response - where - url = mailgunApiPrefixContext context ++ "/messages" - -parseResponse :: (FromJSON a) => Response BCL.ByteString -> Either HailgunErrorResponse a -parseResponse response = statusToResponse . NT.statusCode . responseStatus $ response - where - statusToResponse s - | s == 200 = responseDecode response - | s `elem` [400, 401, 402, 404] = gatherErrors . responseDecode $ response - | s `elem` [500, 502, 503, 504] = serverError - | otherwise = unexpectedError s - -responseDecode :: (FromJSON a) => Response BCL.ByteString -> Either HailgunErrorResponse a -responseDecode = mapError . eitherDecode . responseBody - -retError :: String -> Either HailgunErrorResponse a -retError = Left . toHailgunError - -serverError :: Either HailgunErrorResponse a -serverError = retError "Server Errors - something is wrong on Mailgun’s end" - -unexpectedError :: Int -> Either HailgunErrorResponse a -unexpectedError x = retError $ "Unexpected Non-Standard Mailgun Error: " ++ show x - -mapError :: Either String a -> Either HailgunErrorResponse a -mapError = either (Left . toHailgunError) Right - -gatherErrors :: Either HailgunErrorResponse HailgunErrorResponse -> Either HailgunErrorResponse a -gatherErrors = either Left Left - -mailgunApiPrefix :: String -mailgunApiPrefix = "https://api.mailgun.net/v2" - -mailgunApiPrefixContext :: HailgunContext -> String -mailgunApiPrefixContext context = mailgunApiPrefix ++ "/" ++ hailgunDomain context - -ignoreStatus :: a -> b -> c -> Maybe d -ignoreStatus _ _ _ = Nothing - -data Page = Page - { pageStart :: Integer - , pageLength :: Integer - } - -pageToParams :: Page -> [(BC.ByteString, BC.ByteString)] -pageToParams page = - [ (BC.pack "skip", BC.pack . show . pageStart $ page) - , (BC.pack "limit", BC.pack . show . pageLength $ page) - ] - -toQueryParams :: [(BC.ByteString, BC.ByteString)] -> [(BC.ByteString, Maybe BC.ByteString)] -toQueryParams = fmap (second Just) - -getDomains :: HailgunContext -> Page -> IO (Either HailgunErrorResponse HailgunDomainResponse) -getDomains context page = do - request <- getRequest url context (toQueryParams . pageToParams $ page) - response <- withManager tlsManagerSettings (httpLbs request) - return $ parseResponse response - where - url = mailgunApiPrefix ++ "/domains" - -getRequest :: (MonadThrow m) => String -> HailgunContext -> [(BC.ByteString, Maybe BC.ByteString)] -> m Request -getRequest url context queryParams = do - initRequest <- parseUrl url - let request = applyHailgunAuth context $ initRequest { method = NM.methodGet, checkStatus = ignoreStatus } - return $ setQueryString queryParams request - -postRequest :: (MonadThrow m, MonadIO m) => String -> HailgunContext -> [(BC.ByteString, BC.ByteString)] -> m Request -postRequest url context formParams = do - initRequest <- parseUrl url - let request = initRequest { method = NM.methodPost, checkStatus = ignoreStatus } - requestWithBody <- encodeFormData formParams request - return $ applyHailgunAuth context requestWithBody - -applyHailgunAuth :: HailgunContext -> Request -> Request -applyHailgunAuth context = addRequestProxy (hailgunProxy context) . authRequest - where - addRequestProxy :: Maybe Proxy -> Request -> Request - addRequestProxy (Just proxy) = addProxy (proxyHost proxy) (proxyPort proxy) - addRequestProxy _ = id - - authRequest = applyBasicAuth (BC.pack "api") (BC.pack . hailgunApiKey $ context) - -data HailgunDomainResponse = HailgunDomainResponse - { hdrTotalCount :: Integer - , hdrItems :: [HailgunDomain] - } - -instance FromJSON HailgunDomainResponse where - parseJSON (Object v) = HailgunDomainResponse - <$> v .: T.pack "total_count" - <*> v .: T.pack "items" - parseJSON _ = mzero - -data HailgunDomain = HailgunDomain - { domainName :: T.Text - , domainSmtpLogin :: String - , domainSmtpPassword :: String - , domainCreatedAt :: HailgunTime - , domainWildcard :: Bool - , domainSpamAction :: String -- TODO the domain spam action is probably better specified - } - deriving(Show) - -instance FromJSON HailgunDomain where - parseJSON (Object v) = HailgunDomain - <$> v .: T.pack "name" - <*> v .: T.pack "smtp_login" - <*> v .: T.pack "smtp_password" - <*> v .: T.pack "created_at" - <*> v .: T.pack "wildcard" - <*> v .: T.pack "spam_action" - parseJSON _ = mzero - -newtype HailgunTime = HailgunTime UTCTime - deriving (Eq, Ord, Show) - --- Example Input: 'Thu, 13 Oct 2011 18:02:00 GMT' -instance FromJSON HailgunTime where - parseJSON = withText "HailgunTime" $ \t -> - case parseTime defaultTimeLocale "%a, %d %b %Y %T %Z" (T.unpack t) of - Just d -> pure d - _ -> fail "could not parse Mailgun Style date" +import Mail.Hailgun.Attachment +import Mail.Hailgun.Domains +import Mail.Hailgun.Errors +import Mail.Hailgun.Internal.Data +import Mail.Hailgun.Message +import Mail.Hailgun.Pagination +import Mail.Hailgun.SendEmail -instance ParseTime HailgunTime where - buildTime l = HailgunTime . zonedTimeToUTC . buildTime l +import qualified Data.ByteString.Char8 as BC +import Network.HTTP.Client (Proxy (..)) -toProxy :: String -> Int -> Proxy -toProxy host port = Proxy (BC.pack host) port +-- | A convinience method to create a proxy for the HailgunContext. +toProxy + :: String -- ^ The proxy host + -> Int -- ^ The proxy port + -> Proxy -- ^ The proxy configuration. +toProxy host = Proxy (BC.pack host) diff --git a/Mail/Hailgun/Attachment.hs b/Mail/Hailgun/Attachment.hs new file mode 100644 --- /dev/null +++ b/Mail/Hailgun/Attachment.hs @@ -0,0 +1,29 @@ +module Mail.Hailgun.Attachment + ( createAttachment + , createAttachmentLazy + , addAttachment + ) + where + +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import Data.Monoid +import Mail.Hailgun.Attachment.Internal +import Mail.Hailgun.Internal.Data + +-- | Creates an attachment from a filepath and strict ByteString. +createAttachment :: FilePath -> B.ByteString -> Attachment +createAttachment filename body = Attachment filename (AttachmentBS body) + +-- | Creates an attachment from a filepath and lazy ByteString. +createAttachmentLazy :: FilePath -> BL.ByteString -> Attachment +createAttachmentLazy filename body = Attachment filename (AttachmentLBS body) + +-- | Allows you to add an attachment to an already created HailgunMessage. But please note that it will only +-- add your attachment as a standard attachment. Inline attachments must be added at the time that the +-- HailgunMessage was created. +addAttachment :: Attachment -> Endo HailgunMessage +addAttachment attachment = Endo $ \message -> message + { messageAttachments = (toStandardAttachment . cleanAttachmentFilePath $ attachment) : messageAttachments message + } + diff --git a/Mail/Hailgun/Attachment/Internal.hs b/Mail/Hailgun/Attachment/Internal.hs new file mode 100644 --- /dev/null +++ b/Mail/Hailgun/Attachment/Internal.hs @@ -0,0 +1,17 @@ +module Mail.Hailgun.Attachment.Internal + ( toStandardAttachment + , toInlineAttachment + , cleanAttachmentFilePath + ) where + +import Mail.Hailgun.Internal.Data +import System.FilePath (takeFileName) + +toStandardAttachment :: Attachment -> SpecificAttachment +toStandardAttachment (Attachment filepath body) = SpecificAttachment Attached filepath body + +toInlineAttachment :: Attachment -> SpecificAttachment +toInlineAttachment (Attachment filepath body) = SpecificAttachment Inline filepath body + +cleanAttachmentFilePath :: Attachment -> Attachment +cleanAttachmentFilePath (Attachment filepath body) = Attachment (takeFileName filepath) body diff --git a/Mail/Hailgun/AttachmentsSearch.hs b/Mail/Hailgun/AttachmentsSearch.hs new file mode 100644 --- /dev/null +++ b/Mail/Hailgun/AttachmentsSearch.hs @@ -0,0 +1,38 @@ +module Mail.Hailgun.AttachmentsSearch + ( findInlineImagesInHtmlEmail + , InlineImage(..) + ) where + +import Control.Monad (guard) +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as BC +import Data.List (find, nub) +import Data.Maybe (catMaybes) +import qualified Text.HTML.TagSoup as TS + +-- Finds the unique inline images in the email +findInlineImagesInHtmlEmail :: B.ByteString -> [InlineImage] +findInlineImagesInHtmlEmail = nub . catMaybes . fmap tagToInlineImage . TS.parseTags + +data InlineImage = InlineImage + { imageSrc :: B.ByteString + } deriving (Eq, Show) + +imgTagName :: B.ByteString +imgTagName = BC.pack "img" + +srcTagName :: B.ByteString +srcTagName = BC.pack "src" + +inlineImageUrlPrefix :: B.ByteString +inlineImageUrlPrefix = BC.pack "cid:" + +tagToInlineImage :: TS.Tag B.ByteString -> Maybe InlineImage +tagToInlineImage (TS.TagOpen name attrs) = + if name == imgTagName + then do + srcAttr <- find ((==) srcTagName . fst) attrs + guard (inlineImageUrlPrefix `B.isPrefixOf` snd srcAttr) + return . InlineImage . B.drop (B.length inlineImageUrlPrefix) . snd $ srcAttr + else Nothing +tagToInlineImage _ = Nothing diff --git a/Mail/Hailgun/Communication.hs b/Mail/Hailgun/Communication.hs new file mode 100644 --- /dev/null +++ b/Mail/Hailgun/Communication.hs @@ -0,0 +1,66 @@ +module Mail.Hailgun.Communication + ( getRequest + , postRequest + , toQueryParams + , parseResponse + ) where + +import Control.Arrow (second) +import Control.Monad.Catch (MonadThrow (..)) +import Control.Monad.IO.Class (MonadIO (..)) +import Data.Aeson +import qualified Data.ByteString.Char8 as BC +import qualified Data.ByteString.Lazy.Char8 as BLC +import Data.Foldable (foldMap) +import Data.Monoid +import Mail.Hailgun.Errors +import Mail.Hailgun.Internal.Data +import qualified Network.HTTP.Client as NC +import Network.HTTP.Client.Internal (addProxy) +import Network.HTTP.Client.MultipartFormData (Part (..), formDataBody) +import qualified Network.HTTP.Types.Method as NM +import qualified Network.HTTP.Types.Status as NT + +toQueryParams :: [(BC.ByteString, BC.ByteString)] -> [(BC.ByteString, Maybe BC.ByteString)] +toQueryParams = fmap (second Just) + +getRequest :: (MonadThrow m) => String -> HailgunContext -> [(BC.ByteString, Maybe BC.ByteString)] -> m NC.Request +getRequest url context queryParams = do + initRequest <- NC.parseUrl url + let request = appEndo (applyHailgunAuth context) $ initRequest { NC.method = NM.methodGet, NC.checkStatus = ignoreStatus } + return $ NC.setQueryString queryParams request + +postRequest :: (MonadThrow m, MonadIO m) => String -> HailgunContext -> [Part] -> m NC.Request +postRequest url context parts = do + initRequest <- NC.parseUrl url + let request = initRequest { NC.method = NM.methodPost, NC.checkStatus = ignoreStatus } + requestWithBody <- formDataBody parts request + --requestWithBody <- encodeFormData formParams request + return $ appEndo (applyHailgunAuth context) requestWithBody + +applyHailgunAuth :: HailgunContext -> Endo NC.Request +applyHailgunAuth context = addRequestProxy (hailgunProxy context) <> authRequest context + +addRequestProxy :: Maybe NC.Proxy -> Endo NC.Request +addRequestProxy = foldMap addProxy' + +authRequest :: HailgunContext -> Endo NC.Request +authRequest context = Endo $ NC.applyBasicAuth (BC.pack "api") (BC.pack . hailgunApiKey $ context) + +addProxy' :: NC.Proxy -> Endo NC.Request +addProxy' proxy = Endo $ addProxy (NC.proxyHost proxy) (NC.proxyPort proxy) + +parseResponse :: (FromJSON a) => NC.Response BLC.ByteString -> Either HailgunErrorResponse a +parseResponse response = statusToResponse . NT.statusCode . NC.responseStatus $ response + where + statusToResponse s + | s == 200 = responseDecode response + | s `elem` [400, 401, 402, 404] = gatherErrors . responseDecode $ response + | s `elem` [500, 502, 503, 504] = serverError + | otherwise = unexpectedError s + +responseDecode :: (FromJSON a) => NC.Response BLC.ByteString -> Either HailgunErrorResponse a +responseDecode = mapError . eitherDecode . NC.responseBody + +ignoreStatus :: a -> b -> c -> Maybe d +ignoreStatus _ _ _ = Nothing diff --git a/Mail/Hailgun/Domains.hs b/Mail/Hailgun/Domains.hs new file mode 100644 --- /dev/null +++ b/Mail/Hailgun/Domains.hs @@ -0,0 +1,61 @@ +module Mail.Hailgun.Domains + ( getDomains + , HailgunDomainResponse(..) + , HailgunDomain(..) + ) where + +import Control.Applicative +import Control.Monad (mzero) +import Data.Aeson +import qualified Data.Text as T +import Mail.Hailgun.Communication +import Mail.Hailgun.Errors +import Mail.Hailgun.Internal.Data +import Mail.Hailgun.MailgunApi +import Mail.Hailgun.Pagination +import Network.HTTP.Client (httpLbs, withManager) +import Network.HTTP.Client.TLS (tlsManagerSettings) + +-- | Make a request to Mailgun for the domains against your account. This is a paginated request so you must specify +-- the pages of results that you wish to get back. +getDomains + :: HailgunContext -- ^ The context to operate in which specifies which account to get the domains from. + -> Page -- ^ The page of results that you wish to see returned. + -> IO (Either HailgunErrorResponse HailgunDomainResponse) -- ^ The IO response which is either an error or the list of domains. +getDomains context page = do + request <- getRequest url context (toQueryParams . pageToParams $ page) + response <- withManager tlsManagerSettings (httpLbs request) + return $ parseResponse response + where + url = mailgunApiPrefix ++ "/domains" + +data HailgunDomainResponse = HailgunDomainResponse + { hdrTotalCount :: Integer + , hdrItems :: [HailgunDomain] + } + +instance FromJSON HailgunDomainResponse where + parseJSON (Object v) = HailgunDomainResponse + <$> v .: T.pack "total_count" + <*> v .: T.pack "items" + parseJSON _ = mzero + +data HailgunDomain = HailgunDomain + { domainName :: T.Text + , domainSmtpLogin :: String + , domainSmtpPassword :: String + , domainCreatedAt :: HailgunTime + , domainWildcard :: Bool + , domainSpamAction :: String -- TODO the domain spam action is probably better specified + } + deriving(Show) + +instance FromJSON HailgunDomain where + parseJSON (Object v) = HailgunDomain + <$> v .: T.pack "name" + <*> v .: T.pack "smtp_login" + <*> v .: T.pack "smtp_password" + <*> v .: T.pack "created_at" + <*> v .: T.pack "wildcard" + <*> v .: T.pack "spam_action" + parseJSON _ = mzero diff --git a/Mail/Hailgun/Errors.hs b/Mail/Hailgun/Errors.hs new file mode 100644 --- /dev/null +++ b/Mail/Hailgun/Errors.hs @@ -0,0 +1,43 @@ +module Mail.Hailgun.Errors + ( HailgunErrorResponse(..) -- TODO Make it so that herMessage is a hidden detail in the next version + , toHailgunError + , serverError + , unexpectedError + , gatherErrors + , mapError + ) where + +import Control.Applicative +import Control.Monad (mzero) +import Data.Aeson +import qualified Data.Text as T + +-- TODO make this Hailgun specific and different for the Mailgun api. That way there is the correct +-- separation of concerns. +-- | An error that comes from Mailgun or the Hailgun API. +data HailgunErrorResponse = HailgunErrorResponse + { herMessage :: String -- ^ A generic message describing the error. + } + +toHailgunError :: String -> HailgunErrorResponse +toHailgunError = HailgunErrorResponse + +instance FromJSON HailgunErrorResponse where + parseJSON (Object v) = HailgunErrorResponse + <$> v .: T.pack "message" + parseJSON _ = mzero + +serverError :: Either HailgunErrorResponse a +serverError = retError "Server Errors - something is wrong on Mailgun’s end" + +unexpectedError :: Int -> Either HailgunErrorResponse a +unexpectedError x = retError $ "Unexpected Non-Standard Mailgun Error: " ++ show x + +retError :: String -> Either HailgunErrorResponse a +retError = Left . toHailgunError + +mapError :: Either String a -> Either HailgunErrorResponse a +mapError = either retError Right + +gatherErrors :: Either HailgunErrorResponse HailgunErrorResponse -> Either HailgunErrorResponse a +gatherErrors = either Left Left diff --git a/Mail/Hailgun/Internal/Data.hs b/Mail/Hailgun/Internal/Data.hs new file mode 100644 --- /dev/null +++ b/Mail/Hailgun/Internal/Data.hs @@ -0,0 +1,151 @@ +{-# LANGUAGE CPP #-} +module Mail.Hailgun.Internal.Data + ( HailgunContext(..) + , HailgunMessage(..) + , MessageSubject + , MessageContent(..) + , UnverifiedEmailAddress + , MessageRecipients(..) + , emptyMessageRecipients + , HailgunErrorMessage + , HailgunTime(..) + , Attachment(..) + , SpecificAttachment(..) + , AttachmentBody(..) + , AttachmentType(..) + ) where + +import Control.Applicative +import Data.Aeson +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import qualified Data.Text as T +import Data.Time.Clock (UTCTime (..)) +import Data.Time.Format (ParseTime (..), parseTime) +import Data.Time.LocalTime (zonedTimeToUTC) +import qualified Network.HTTP.Client as NHC +import qualified Text.Email.Validate as TEV + +#if MIN_VERSION_time(1,5,0) +import Data.Time.Format (defaultTimeLocale) +#else +import System.Locale (defaultTimeLocale) +#endif + +type UnverifiedEmailAddress = B.ByteString -- ^ Represents an email address that is not yet verified. +type MessageSubject = String -- ^ Represents a message subject. + +-- | A generic error message that is returned by the Hailgun library. +type HailgunErrorMessage = String + +-- | When comunnicating to the Mailgun service you need to have some common pieces of information to +-- authenticate successfully. This context encapsulates that required information. +data HailgunContext = HailgunContext + -- TODO better way to represent a domain + { hailgunDomain :: String -- ^ The domain of the mailgun account that you wish to send the emails through. + , hailgunApiKey :: String -- ^ The API key for the mailgun account so that you can successfully make requests. Please note that it should include the 'key' prefix. + , hailgunProxy :: Maybe NHC.Proxy + } + +-- | Any email content that you wish to send should be encoded into these types before it is sent. +-- Currently, according to the API, you should always send a Text Only part in the email and you can +-- optionally add a nicely formatted HTML version of that email to the sent message. +-- +-- @ +-- It is best to send multi-part emails using both text and HTML or text only. Sending HTML only +-- email is not well received by ESPs. +-- @ +-- () +-- +-- This API mirrors that advice so that you can always get it right. +data MessageContent + -- | The Text only version of the message content. + = TextOnly + { textContent :: B.ByteString + } + -- | A message that contains both a Text version of the email content and a HTML version of the email content. + | TextAndHTML + { textContent :: B.ByteString -- ^ The text content that you wish to send (please note that many clients will take the HTML version first if it is present but that the text version is a great fallback). + , htmlContent :: B.ByteString -- ^ The HTML content that you wish to send. + } + +-- | A Hailgun Email message that may be sent. It contains important information such as the address +-- that the email is from, the addresses that it should be going to, the subject of the message and +-- the content of the message. Any email that you wish to send via this api must be converted into +-- this structure first. To create a message then please use the hailgunMessage interface. +data HailgunMessage = HailgunMessage + { messageSubject :: MessageSubject + , messageContent :: MessageContent + , messageFrom :: TEV.EmailAddress + , messageTo :: [TEV.EmailAddress] + , messageCC :: [TEV.EmailAddress] + , messageBCC :: [TEV.EmailAddress] + , messageAttachments :: [SpecificAttachment] + } + -- TODO o:tag support + -- TODO o:campaign support + -- messageDKIMSupport :: Bool TODO o:dkim support + -- TODO o:deliverytime support for up to three days in the future + -- TODO o:testmode support + -- TODO o:tracking support + -- TODO o:tracking-clicks support + -- TODO o:tracking-opens support + -- TODO custom mime header support + -- TODO custom message data support + +-- | An Attachment that may be sent. It contains the file path of the attachment and the data that you wish to send in +-- the attachment body. It is important to note that this data type makes no distinction between standard attachments +-- and HTML inline attachments. See sendEmail for more details on how to make your attachments behave like inline +-- attachments. +data Attachment = Attachment + { attachmentFilePath :: FilePath + , attachmentBody :: AttachmentBody + } + +-- | An Attachment body is the raw data that you want to send with your attachment. +data AttachmentBody + = AttachmentBS B.ByteString -- ^ A strict ByteString representation of your data. + | AttachmentLBS BL.ByteString -- ^ A lazy ByteString representation of your data. + +data SpecificAttachment = SpecificAttachment + { saType :: AttachmentType + , saFilePath :: FilePath + , saBody :: AttachmentBody + } + +data AttachmentType = Attached | Inline deriving (Eq, Show) + +-- | No recipients for your email. Useful singleton instance to avoid boilerplate in your code. For +-- example: +-- +-- @ +-- toBob = emptyMessageRecipients { recipientsTo = [\"bob\@bob.test\"] } +-- @ +emptyMessageRecipients :: MessageRecipients +emptyMessageRecipients = MessageRecipients [] [] [] + +-- | A collection of unverified email recipients separated into the To, CC and BCC groupings that +-- email supports. +data MessageRecipients = MessageRecipients + { recipientsTo :: [UnverifiedEmailAddress] -- ^ The people to email directly. + , recipientsCC :: [UnverifiedEmailAddress] -- ^ The people to \"Carbon Copy\" into the email. Honestly, why is that term not deprecated yet? + , recipientsBCC :: [UnverifiedEmailAddress] -- ^ The people to \"Blind Carbon Copy\" into the email. There really needs to be a better name for this too. + } + +-- The user should just give us a list of attachments and we should automatically make them inline or not +-- We should consider sending the HTML message as a quoted-string: http://hackage.haskell.org/package/dataenc-0.14.0.5/docs/Codec-Binary-QuotedPrintable.html +-- We should use TagSoup to parse the constructed HTML message so that we can see if any inline images are expected: + +-- | A wrapper for UTCTime so that we can always pass correctly formatted times to Mailgun. +newtype HailgunTime = HailgunTime UTCTime + deriving (Eq, Ord, Show) + +-- Example Input: 'Thu, 13 Oct 2011 18:02:00 GMT' +instance FromJSON HailgunTime where + parseJSON = withText "HailgunTime" $ \t -> + case parseTime defaultTimeLocale "%a, %d %b %Y %T %Z" (T.unpack t) of + Just d -> pure d + _ -> fail "could not parse Mailgun Style date" + +instance ParseTime HailgunTime where + buildTime l = HailgunTime . zonedTimeToUTC . buildTime l diff --git a/Mail/Hailgun/MailgunApi.hs b/Mail/Hailgun/MailgunApi.hs new file mode 100644 --- /dev/null +++ b/Mail/Hailgun/MailgunApi.hs @@ -0,0 +1,12 @@ +module Mail.Hailgun.MailgunApi + ( mailgunApiPrefix + , mailgunApiPrefixContext + ) where + +import Mail.Hailgun.Internal.Data + +mailgunApiPrefix :: String +mailgunApiPrefix = "https://api.mailgun.net/v2" + +mailgunApiPrefixContext :: HailgunContext -> String +mailgunApiPrefixContext context = mailgunApiPrefix ++ "/" ++ hailgunDomain context diff --git a/Mail/Hailgun/Message.hs b/Mail/Hailgun/Message.hs new file mode 100644 --- /dev/null +++ b/Mail/Hailgun/Message.hs @@ -0,0 +1,72 @@ +module Mail.Hailgun.Message + ( hailgunMessage + ) where + +import Control.Applicative +import qualified Data.ByteString.Char8 as BC +import Data.List (find) +import Mail.Hailgun.Attachment.Internal +import Mail.Hailgun.AttachmentsSearch +import Mail.Hailgun.Internal.Data +import Text.Email.Validate + +-- | A method to construct a HailgunMessage. You require a subject, content, From address and people +-- to send the email to and it will give you back a valid Hailgun email message. Or it will error +-- out while trying. +hailgunMessage + :: MessageSubject -- ^ The purpose of the email surmised. + -> MessageContent -- ^ The full body of the email. + -> UnverifiedEmailAddress -- ^ The email account that the recipients should respond to in order to get back to us. + -> MessageRecipients -- ^ The people that should recieve this email. + -> [Attachment] -- ^ The attachments that you want to attach to the email; standard or inline. + -> Either HailgunErrorMessage HailgunMessage -- ^ Either an error while trying to create a valid message or a valid message. +hailgunMessage subject content sender recipients simpleAttachments = do + from <- validate sender + to <- mapM validate (recipientsTo recipients) + cc <- mapM validate (recipientsCC recipients) + bcc <- mapM validate (recipientsBCC recipients) + attachments <- attachmentsInferredFromMessage content cleanAttachments + return HailgunMessage + { messageSubject = subject + , messageContent = content + , messageFrom = from + , messageTo = to + , messageCC = cc + , messageBCC = bcc + , messageAttachments = attachments + } + where + cleanAttachments = fmap cleanAttachmentFilePath simpleAttachments + +attachmentsInferredFromMessage :: MessageContent -> [Attachment] -> Either String [SpecificAttachment] +attachmentsInferredFromMessage mContent simpleAttachments = + case mContent of + (TextOnly _) -> return . fmap toStandardAttachment $ simpleAttachments + th@(TextAndHTML {}) -> convertAttachments simpleAttachments (findInlineImagesInHtmlEmail . htmlContent $ th) + +convertAttachments :: [Attachment] -> [InlineImage] -> Either String [SpecificAttachment] +convertAttachments attachments images = do + inlineAttachments <- sequence (fmap (findAttachmentForImage attachments) images) + let standardAttachments = toStandardAttachment <$> attachments `notInSpecific` inlineAttachments + return $ inlineAttachments ++ standardAttachments + +notInSpecific :: [Attachment] -> [SpecificAttachment] -> [Attachment] +notInSpecific simpleAttachments specificAttachments = + filter (\sa -> attachmentFilePath sa `notElem` specificFilePaths) simpleAttachments + where + specificFilePaths = fmap saFilePath specificAttachments + +findAttachmentForImage :: [Attachment] -> InlineImage -> Either String SpecificAttachment +findAttachmentForImage attachments image = + case find (`attachmentForInlineImage` image) attachments of + Nothing -> Left . missingInlineImageErrorMessage $ image + Just attachment -> Right . toInlineAttachment $ attachment + +missingInlineImageErrorMessage :: InlineImage -> String +missingInlineImageErrorMessage image = + "Could not find an attachment for the inline image: " + ++ (show . imageSrc $ image) + ++ ". Either provide the attachment or remove the inline image from the HTML email." + +attachmentForInlineImage :: Attachment -> InlineImage -> Bool +attachmentForInlineImage attachment image = (BC.pack . attachmentFilePath $ attachment) == imageSrc image diff --git a/Mail/Hailgun/Pagination.hs b/Mail/Hailgun/Pagination.hs new file mode 100644 --- /dev/null +++ b/Mail/Hailgun/Pagination.hs @@ -0,0 +1,20 @@ +module Mail.Hailgun.Pagination + ( Page(..) + , pageToParams + ) where + +import qualified Data.ByteString.Char8 as BC + +-- | Represents a single page of results. You specify a page of results when you wish to to make a request to a +-- paginated resource. +data Page = Page + { pageStart :: Integer + , pageLength :: Integer + } + +pageToParams :: Page -> [(BC.ByteString, BC.ByteString)] +pageToParams page = + [ (BC.pack "skip", BC.pack . show . pageStart $ page) + , (BC.pack "limit", BC.pack . show . pageLength $ page) + ] + diff --git a/Mail/Hailgun/PartUtil.hs b/Mail/Hailgun/PartUtil.hs new file mode 100644 --- /dev/null +++ b/Mail/Hailgun/PartUtil.hs @@ -0,0 +1,30 @@ +module Mail.Hailgun.PartUtil + ( paramsToPart + , attachmentToPart + ) where + +import qualified Data.ByteString.Char8 as BC +import qualified Data.Text as T +import Data.Text.Encoding (decodeUtf8) +import Mail.Hailgun.Internal.Data +import qualified Network.HTTP.Client as NC +import qualified Network.HTTP.Client.MultipartFormData as NCM + +paramsToPart :: (BC.ByteString, BC.ByteString) -> NCM.Part +paramsToPart (name, content) = NCM.partBS (decodeUtf8 name) content + +attachmentToPart :: SpecificAttachment -> NCM.Part +attachmentToPart (SpecificAttachment attachmentType filename body) = + NCM.partFileRequestBody partName filename requestBody + where + partName = attachmentTypeToName attachmentType + requestBody = attachmentBodyToRequestBody body + +attachmentBodyToRequestBody :: AttachmentBody -> NC.RequestBody +attachmentBodyToRequestBody (AttachmentBS body) = NC.RequestBodyBS body +attachmentBodyToRequestBody (AttachmentLBS body) = NC.RequestBodyLBS body + +attachmentTypeToName :: AttachmentType -> T.Text +attachmentTypeToName Attached = T.pack "attachment" +attachmentTypeToName Inline = T.pack "inline" + diff --git a/Mail/Hailgun/SendEmail.hs b/Mail/Hailgun/SendEmail.hs new file mode 100644 --- /dev/null +++ b/Mail/Hailgun/SendEmail.hs @@ -0,0 +1,73 @@ +module Mail.Hailgun.SendEmail + ( sendEmail + , HailgunSendResponse(..) + ) where + +import Control.Applicative +import Control.Monad (mzero) +import Data.Aeson +import qualified Data.ByteString.Char8 as BC +import qualified Data.Text as T +import Mail.Hailgun.Communication +import Mail.Hailgun.Errors +import Mail.Hailgun.Internal.Data +import Mail.Hailgun.MailgunApi +import Mail.Hailgun.PartUtil +import Network.HTTP.Client (httpLbs, withManager) +import qualified Network.HTTP.Client.MultipartFormData as NCM +import Network.HTTP.Client.TLS (tlsManagerSettings) +import Text.Email.Validate (EmailAddress, + toByteString) + +-- | Send an email using the Mailgun API's. This method is capable of sending a message over the +-- Mailgun service. All it needs is the appropriate context. +sendEmail + :: HailgunContext -- ^ The Mailgun context to operate in. + -> HailgunMessage -- ^ The Hailgun message to be sent. + -> IO (Either HailgunErrorResponse HailgunSendResponse) -- ^ The result of the sent email. Either a sent email or a successful send. +sendEmail context message = do + request <- postRequest url context (toEmailParts message) + response <- withManager tlsManagerSettings (httpLbs request) + return $ parseResponse response + where + url = mailgunApiPrefixContext context ++ "/messages" + +toEmailParts :: HailgunMessage -> [NCM.Part] +toEmailParts message = params ++ attachmentParts + where + params = map paramsToPart . toSimpleEmailParts $ message + attachmentParts = map attachmentToPart . messageAttachments $ message + +toSimpleEmailParts :: HailgunMessage -> [(BC.ByteString, BC.ByteString)] +toSimpleEmailParts message = + [ (BC.pack "from", toByteString . messageFrom $ message) + , (BC.pack "subject", BC.pack $ messageSubject message) + ] ++ to + ++ cc + ++ bcc + ++ fromContent (messageContent message) + where + to = convertEmails (BC.pack "to") . messageTo $ message + cc = convertEmails (BC.pack "cc") . messageCC $ message + bcc = convertEmails (BC.pack "bcc") . messageBCC $ message + + fromContent :: MessageContent -> [(BC.ByteString, BC.ByteString)] + fromContent t@(TextOnly _) = [ (BC.pack "text", textContent t) ] + fromContent th@(TextAndHTML {}) = (BC.pack "html", htmlContent th) : fromContent (TextOnly . textContent $ th) + + convertEmails :: BC.ByteString -> [EmailAddress] -> [(BC.ByteString, BC.ByteString)] + convertEmails prefix = fmap ((,) prefix . toByteString) + +-- TODO replace with MailgunSendResponse +-- | The response to an email being accepted by the Mailgun API. +data HailgunSendResponse = HailgunSendResponse + { hsrMessage :: String -- ^ The freeform message from the mailgun API. + , hsrId :: String -- ^ The ID of the message that has been accepted by the Mailgun api. + } + +instance FromJSON HailgunSendResponse where + parseJSON (Object v) = HailgunSendResponse + <$> v .: T.pack "message" + <*> v .: T.pack "id" + parseJSON _ = mzero + diff --git a/hailgun.cabal b/hailgun.cabal --- a/hailgun.cabal +++ b/hailgun.cabal @@ -10,7 +10,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 0.2.1.0 +version: 0.3.0.0 -- A short (one-line) description of the package. synopsis: Mailgun REST api interface for Haskell. @@ -55,6 +55,20 @@ library exposed-modules: Mail.Hailgun + , Mail.Hailgun.Attachment + + other-modules: Mail.Hailgun.Internal.Data + , Mail.Hailgun.Attachment.Internal + , Mail.Hailgun.AttachmentsSearch + , Mail.Hailgun.Communication + , Mail.Hailgun.Domains + , Mail.Hailgun.Errors + , Mail.Hailgun.MailgunApi + , Mail.Hailgun.Message + , Mail.Hailgun.Pagination + , Mail.Hailgun.PartUtil + , Mail.Hailgun.SendEmail + build-depends: base >= 4.6 && < 5 , bytestring >= 0.10.4 && <= 0.11 , aeson == 0.7.* @@ -65,6 +79,9 @@ , email-validate == 2.0.* , http-types == 0.8.* , exceptions >= 0.4 + , tagsoup == 0.13.* + , filepath >= 1 && < 2 + if flag(newtime) Build-Depends: time == 1.5.* else