module Mail.Hailgun
( sendEmail
, hailgunMessage
, HailgunMessage
, HailgunContext(..)
, MessageSubject
, MessageContent(..)
, MessageRecipients(..)
, emptyMessageRecipients
, UnverifiedEmailAddress
, HailgunSendResponse(..)
, HailgunErrorMessage
, HailgunErrorResponse(..)
, getDomains
, Page(..)
, HailgunDomain(..)
, HailgunDomainResponse(..)
, HailgunTime(..)
, toProxy
) 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
type UnverifiedEmailAddress = B.ByteString
type MessageSubject = String
data MessageContent
= TextOnly
{ textContent :: B.ByteString
}
| TextAndHTML
{ textContent :: B.ByteString
, htmlContent :: B.ByteString
}
data HailgunMessage = HailgunMessage
{ messageSubject :: MessageSubject
, messageContent :: MessageContent
, messageFrom :: EmailAddress
, messageTo :: [EmailAddress]
, messageCC :: [EmailAddress]
, messageBCC :: [EmailAddress]
}
emptyMessageRecipients :: MessageRecipients
emptyMessageRecipients = MessageRecipients [] [] []
data MessageRecipients = MessageRecipients
{ recipientsTo :: [UnverifiedEmailAddress]
, recipientsCC :: [UnverifiedEmailAddress]
, recipientsBCC :: [UnverifiedEmailAddress]
}
type HailgunErrorMessage = String
hailgunMessage
:: MessageSubject
-> MessageContent
-> UnverifiedEmailAddress
-> MessageRecipients
-> Either HailgunErrorMessage HailgunMessage
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)
data HailgunContext = HailgunContext
{ hailgunDomain :: String
, hailgunApiKey :: String
, hailgunProxy :: Maybe Proxy
}
data HailgunSendResponse = HailgunSendResponse
{ hsrMessage :: String
, hsrId :: String
}
data HailgunErrorResponse = HailgunErrorResponse
{ herMessage :: String
}
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
sendEmail
:: HailgunContext
-> HailgunMessage
-> IO (Either HailgunErrorResponse HailgunSendResponse)
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
}
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)
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
toProxy :: String -> Int -> Proxy
toProxy host port = Proxy (BC.pack host) port