diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -0,0 +1,2 @@ +## 0.1.0.0 +* First release. diff --git a/license b/license new file mode 100644 --- /dev/null +++ b/license @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2023 Daniel Casanueva + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/mailtrap.cabal b/mailtrap.cabal new file mode 100644 --- /dev/null +++ b/mailtrap.cabal @@ -0,0 +1,29 @@ +name: mailtrap +version: 0.1.0.0 +category: Email +synopsis: Mailtrap API library. +description: + Mailtrap API library. For more information, + visit [the repository](https://gitlab.com/daniel-casanueva/haskell/mailtrap). +author: Daniel Casanueva (daniel.casanueva `at` proton.me) +maintainer: Daniel Casanueva (daniel.casanueva `at` proton.me) +homepage: https://gitlab.com/daniel-casanueva/haskell/mailtrap +license: MIT +license-file: license +cabal-version: 1.18 +build-type: Simple +extra-doc-files: readme.md, changelog.md + +library + default-language: Haskell2010 + default-extensions: + ImportQualifiedPost, OverloadedStrings, KindSignatures + , ScopedTypeVariables, TypeApplications, DataKinds + , GeneralizedNewtypeDeriving, CPP + ghc-options: -Wall -Wunused-packages + hs-source-dirs: src + build-depends: + base < 5, text, aeson, email-validate, bytestring + , mime-types, base64, blaze-html, uuid-types + , http-conduit, filepath, time, unordered-containers + exposed-modules: Network.Mail.Mailtrap diff --git a/readme.md b/readme.md new file mode 100644 --- /dev/null +++ b/readme.md @@ -0,0 +1,8 @@ + +## mailtrap + +This library supplies functions to use the +[Mailtrap API](https://api-docs.mailtrap.io/docs/mailtrap-api-docs) +from a Haskell project. + +It implements both email sending and testing. diff --git a/src/Network/Mail/Mailtrap.hs b/src/Network/Mail/Mailtrap.hs new file mode 100644 --- /dev/null +++ b/src/Network/Mail/Mailtrap.hs @@ -0,0 +1,465 @@ +---------------------------------------------------------------------------------------------------- +-- | Mailtrap API. +module Network.Mail.Mailtrap + ( -- * Tokens + Token (..) + , Exception (..) + -- * Accounts + , AccountID (..) + , Account (..) + , getAllAccounts + -- * Attachments + , Disposition (..) + , setDisposition + , Attachment (..) + , attachmentFromFile + -- * Templates + , Template (..) + , template + , setTemplateVariable + -- * Testing inboxes + , InboxID (..) + , getInboxes + , InboxMessageID (..) + , getInboxMessages + , downloadMessageRaw + , downloadMessageEML + , downloadMessageText + , downloadMessageHTML + -- * Sending e-mails + , NamedEmailAddress (..) + , parseEmailAddress + , MessageID (..) + , Message (..) + , EmailBody (..) + , Email (..) + , sendEmail + , sendTestEmail + ) where + +-- base +import Control.Exception qualified as Base +import GHC.TypeLits (Symbol, KnownSymbol, symbolVal) +import Data.Proxy +import Data.String (fromString) +-- text +import Data.Text (Text) +import Data.Text qualified as Text +import Data.Text.Encoding (decodeUtf8, encodeUtf8) +-- email-validate +import Text.Email.Validate (EmailAddress) +import Text.Email.Validate qualified as Email +-- bytestring +import Data.ByteString (ByteString) +import Data.ByteString qualified as ByteString +-- mime-types +import Network.Mime (MimeType, defaultMimeLookup) +-- aeson +import Data.Aeson (ToJSON, (.=), FromJSON, (.:)) +import Data.Aeson qualified as JSON +#if MIN_VERSION_aeson(2,0,0) +import Data.Aeson.KeyMap qualified as KeyMap +import Data.Aeson.Key qualified as Key +#else +import Data.HashMap.Strict qualified as HashMap +#endif +-- base64 +import Data.ByteString.Base64 (encodeBase64) +-- blaze-html +import Text.Blaze.Html (Html) +import Text.Blaze.Html.Renderer.Text (renderHtml) +-- uuid +import Data.UUID.Types (UUID) +-- http-conduit +import Network.HTTP.Simple qualified as HTTP +-- filepath +import System.FilePath (takeFileName) +-- time +import Data.Time.Clock (UTCTime) + +-- | Authorization token. +newtype Token = Token Text deriving (Eq, Show) + +-- | Exceptions thrown by functions from this module. +data Exception = + -- | API request returned list of errors. + -- HTTP status code and error messages. + MultipleErrors Int [Text] + -- | API request returned a single error message. + -- HTTP status code and error message. + | SingleError Int Text + -- | Parsing failed. + -- Input that failed to parse plus error message. + | ParsingError ByteString String + deriving Show + +instance Base.Exception Exception + +-- | Constructor of simple error. +singleError :: Int -> JSONResp "error" Text -> Exception +singleError code (JSONResp err) = SingleError code err + +-- | Constructor of multiple errors. +multipleErrors :: Int -> JSONResp "errors" [Text] -> Exception +multipleErrors code (JSONResp errs) = MultipleErrors code errs + +-- | JSON object wrapper to help with parsing HTTP response. +data JSONResp (k :: Symbol) a = JSONResp { fromJSONResp :: a } + +instance (KnownSymbol k, FromJSON a) => FromJSON (JSONResp k a) where + parseJSON = + let k = fromString $ symbolVal $ Proxy @k + in JSON.withObject "JSONResp" $ fmap JSONResp . (.: k) + +-- | Wrapper that provides a text-based 'FromJSON' instance. +newtype AsText a = AsText { asText :: a } + +instance FromJSON a => FromJSON (AsText a) where + parseJSON = JSON.withText "AsText" $ + either fail (pure . AsText) . JSON.eitherDecodeStrict . encodeUtf8 + +-- | Generic API query that returns JSON. +genericQuery + :: (FromJSON err, ToJSON a, FromJSON b) + => ByteString -- ^ HTTP method. + -> ByteString -- ^ API URL. + -> ByteString -- ^ HTTP path. + -> Token -- ^ API token. + -> (Int -> err -> Exception) -- ^ Error parsing. + -> Maybe a -- ^ Body. + -> IO b -- ^ Response. +genericQuery method url path (Token token) ferr mbody = do + let req = HTTP.setRequestMethod method + $ HTTP.setRequestHost url + $ HTTP.setRequestPort 443 + $ HTTP.setRequestPath path + $ HTTP.setRequestSecure True + $ maybe id HTTP.setRequestBodyJSON mbody + $ HTTP.addRequestHeader "Api-Token" (encodeUtf8 token) + $ HTTP.defaultRequest + resp <- HTTP.httpBS req + let code = HTTP.getResponseStatusCode resp + body = HTTP.getResponseBody resp + case code of + 200 -> + either (Base.throwIO . ParsingError body) pure $ + JSON.eitherDecodeStrict body + _ -> + either (Base.throwIO . ParsingError body) (Base.throwIO . ferr code) $ + JSON.eitherDecodeStrict body + +-- | Helper to set an empty body when using 'genericQuery'. +noBody :: Maybe () +noBody = Nothing + +-- | Generic API query to download files. +genericDownload + :: ByteString -- ^ API URL. + -> ByteString -- ^ HTTP path. + -> Token -- ^ API token. + -> IO ByteString -- ^ Response. +genericDownload url path (Token token) = do + let req = HTTP.setRequestMethod "GET" + $ HTTP.setRequestHost url + $ HTTP.setRequestPort 443 + $ HTTP.setRequestPath path + $ HTTP.setRequestSecure True + $ HTTP.addRequestHeader "Api-Token" (encodeUtf8 token) + $ HTTP.defaultRequest + resp <- HTTP.httpBS req + let code = HTTP.getResponseStatusCode resp + body = HTTP.getResponseBody resp + case code of + 200 -> pure body + 404 -> Base.throwIO $ SingleError 404 "File not found." + _ -> + either (Base.throwIO . ParsingError body) (Base.throwIO . singleError code) $ + JSON.eitherDecodeStrict body + +-- | Mailtrap account ID. +newtype AccountID = AccountID Int deriving (Eq, Show, FromJSON) + +-- | Mailtrap account. +data Account = Account + { account_id :: AccountID + , account_name :: Text + } deriving Show + +instance FromJSON Account where + parseJSON = JSON.withObject "Account" $ \o -> + Account <$> o .: "id" <*> o .: "name" + +-- | Get all the accounts the given token has access to. +getAllAccounts :: Token -> IO [Account] +getAllAccounts token = genericQuery "GET" "mailtrap.io" "/api/accounts" token singleError noBody + +-- | 'EmailAddress' wrapper to provide 'ToJSON' and 'FromJSON' instances. +newtype EmailAddressJSON = EmailAddressJSON { fromEmailAddressJSON :: EmailAddress } + +instance ToJSON EmailAddressJSON where + toJSON = JSON.String . decodeUtf8 . Email.toByteString . fromEmailAddressJSON + +instance FromJSON EmailAddressJSON where + parseJSON = JSON.withText "EmailAddressJSON" $ \t -> + either fail (pure . EmailAddressJSON) $ Email.validate $ encodeUtf8 t + +-- | An e-mail address with a name. +data NamedEmailAddress = NamedEmailAddress + { emailAddress :: EmailAddress + , emailAddressName :: Text + } deriving Show + +instance ToJSON NamedEmailAddress where + toJSON addr = JSON.object + [ "email" .= EmailAddressJSON (emailAddress addr) + , "name" .= emailAddressName addr + ] + +-- | Attempt to parse an e-mail address +parseEmailAddress :: ByteString -> Either String EmailAddress +parseEmailAddress = Email.validate + +-- | Attachment disposition. +data Disposition = + -- | Inline with identifier. + Inline Text + | Attached + deriving Show + +-- | File that can be attached to an e-mail. +data Attachment = Attachment + { -- | File name. + attachment_name :: Text + -- | MIME type of the content. + , attachment_type :: MimeType + -- | Attachment content. + , attachment_content :: ByteString + -- | Attachment disposition. + , attachment_disposition :: Disposition + } deriving Show + +-- | Create an attachment from a file. It guesses the mime type from +-- the file extension. Disposition is set to 'Attached'. +-- The file is read strictly. +attachmentFromFile :: FilePath -> IO Attachment +attachmentFromFile fp = do + let fptext :: Text + fptext = Text.pack $ takeFileName fp + bytes <- ByteString.readFile fp + pure $ Attachment + { attachment_name = fptext + , attachment_type = defaultMimeLookup fptext + , attachment_content = bytes + , attachment_disposition = Attached + } + +-- | Set an attachment's disposition. +setDisposition :: Disposition -> Attachment -> Attachment +setDisposition d a = a { attachment_disposition = d } + +instance ToJSON Attachment where + toJSON att = JSON.object $ + [ "filename" .= attachment_name att + , "type" .= decodeUtf8 (attachment_type att) + , "content" .= encodeBase64 (attachment_content att) + , "disposition" .= + (case attachment_disposition att of + Inline _ -> "inline" :: Text + Attached -> "attachment" + ) + ] ++ (case attachment_disposition att of + Inline i -> [ "content_id" .= i ] + Attached -> [] + ) + +-- | An e-mail body. +data EmailBody = + -- | Plain-text body. + PlainTextBody Text + -- | HTML-only body. + | HTMLOnlyBody Html + -- | HTML body with text fallback. + | HTMLBody Html Text + +-- | E-mail message, including subject and body. +data Message = Message + { message_subject :: Text + , message_body :: EmailBody + -- | Message category. + , message_category :: Text + } + +-- | Template that can be used when sending e-mails. +data Template = Template + { -- | ID of the template. + template_id :: UUID + -- | Template variable assignments. + , template_variables :: JSON.Object + } deriving Show + +-- | Template with no variable set. +template :: UUID -> Template +#if MIN_VERSION_aeson(2,0,0) +template i = Template i KeyMap.empty +#else +template i = Template i HashMap.empty +#endif + +-- | Set template variable. +setTemplateVariable :: ToJSON a => Text -> a -> Template -> Template +setTemplateVariable k x t = +#if MIN_VERSION_aeson(2,0,0) + t { template_variables = KeyMap.insert (Key.fromText k) (JSON.toJSON x) $ template_variables t } +#else + t { template_variables = HashMap.insert k (JSON.toJSON x) $ template_variables t } +#endif + +-- | E-mail that can be sent using 'sendEmail'. +data Email = Email + { -- | Sender address. + email_from :: NamedEmailAddress + -- | Recipient list. Max 1000. + , email_to :: [NamedEmailAddress] + -- | Carbon Copy recipients. + , email_cc :: [NamedEmailAddress] + -- | Blind Carbon Copy recipients. + , email_bcc :: [NamedEmailAddress] + -- | Files attached to the e-mail. + , email_attachments :: [Attachment] + -- | Custom JSON object. + , email_custom :: JSON.Object + -- | Message to send. + , email_message :: Either Template Message + } + +instance ToJSON Email where + toJSON email = JSON.object $ + [ "from" .= email_from email + , "to" .= email_to email + , "cc" .= email_cc email + , "bcc" .= email_bcc email + , "attachments" .= email_attachments email + , "custom_variables" .= email_custom email + ] ++ (case email_message email of + Left temp -> + [ "template_uuid" .= template_id temp + , "template_variables" .= template_variables temp + ] + Right msg -> + [ "subject" .= message_subject msg + , "category" .= message_category msg + ] ++ (case message_body msg of + PlainTextBody t -> [ "text" .= t ] + HTMLOnlyBody h -> [ "html" .= renderHtml h ] + HTMLBody h t -> [ "html" .= renderHtml h, "text" .= t ] + ) + ) + +-- | Testing inbox identifier. +newtype InboxID = InboxID Int deriving (Eq, Show, FromJSON) + +-- | Testing inbox. +data Inbox = Inbox + { inbox_id :: InboxID + , inbox_name :: Text + -- | Number of emails in the inbox. + , inbox_emailCount :: Int + -- | Number of unread emails in the inbox. + , inbox_unreadCount :: Int + , inbox_maxSize :: Int + } deriving Show + +instance FromJSON Inbox where + parseJSON = JSON.withObject "Inbox" $ \o -> Inbox + <$> o .: "id" + <*> o .: "name" + <*> o .: "emails_count" + <*> o .: "emails_unread_count" + <*> o .: "max_size" + +-- | Get all inboxes from an account. +getInboxes :: Token -> AccountID -> IO [Inbox] +getInboxes token (AccountID i) = + let path = fromString $ "/api/accounts/" ++ show i ++ "/inboxes" + in genericQuery "GET" "mailtrap.io" path token singleError noBody + +-- | Inbox message identifier. +newtype InboxMessageID = InboxMessageID Int deriving (Eq, Show, FromJSON) + +-- | A message in a testing inbox. +data InboxMessage = InboxMessage + { inboxMessage_id :: InboxMessageID + , inboxMessage_inbox :: InboxID + , inboxMessage_sentAt :: UTCTime + , inboxMessage_from :: EmailAddress + , inboxMessage_to :: EmailAddress + , inboxMessage_subject :: Text + , inboxMessage_isRead :: Bool + } deriving Show + +instance FromJSON InboxMessage where + parseJSON = JSON.withObject "InboxMessage" $ \o -> InboxMessage + <$> o .: "id" + <*> o .: "inbox_id" + <*> o .: "sent_at" + <*> (fromEmailAddressJSON <$> o .: "from_email") + <*> (fromEmailAddressJSON <$> o .: "to_email") + <*> o .: "subject" + <*> o .: "is_read" + +-- | Get all inbox messages from an testing inbox. +getInboxMessages :: Token -> AccountID -> InboxID -> IO [InboxMessage] +getInboxMessages token (AccountID accid) (InboxID inboxid) = + let path = fromString $ "/api/accounts/" ++ show accid + ++ "/inboxes/" ++ show inboxid ++ "/messages" + in genericQuery "GET" "mailtrap.io" path token singleError noBody + +-- | Generic function to implement all the message download functions in one place. +downloadMessageGeneric + :: String -- ^ Extension + -> Token -> AccountID -> InboxID -> InboxMessageID -> IO Text +downloadMessageGeneric ext token (AccountID accid) (InboxID inboxid) (InboxMessageID msgid) = + let path = fromString $ "/api/accounts/" ++ show accid + ++ "/inboxes/" ++ show inboxid + ++ "/messages/" ++ show msgid + ++ "/body." ++ ext + in decodeUtf8 <$> genericDownload "mailtrap.io" path token + +-- | Download inbox message raw email body. +downloadMessageRaw :: Token -> AccountID -> InboxID -> InboxMessageID -> IO Text +downloadMessageRaw = downloadMessageGeneric "raw" + +-- | Download inbox message in EML format. +downloadMessageEML :: Token -> AccountID -> InboxID -> InboxMessageID -> IO Text +downloadMessageEML = downloadMessageGeneric "eml" + +-- | Download inbox message text part. +downloadMessageText :: Token -> AccountID -> InboxID -> InboxMessageID -> IO Text +downloadMessageText = downloadMessageGeneric "txt" + +-- | Download inbox message HTML part. +downloadMessageHTML :: Token -> AccountID -> InboxID -> InboxMessageID -> IO Text +downloadMessageHTML = downloadMessageGeneric "html" + +-- | Production message identifier. +newtype MessageID = MessageID UUID deriving (Eq, Show, FromJSON) + +-- | Send an e-mail and return the list of IDs of the messages sent (one per recipient). +sendEmail :: Token -> Email -> IO [MessageID] +sendEmail = genericSendEmail Nothing + +-- | Send a testing e-mail to the given inbox and return the list of IDs of the messages +-- sent (one per recipient). +sendTestEmail :: Token -> InboxID -> Email -> IO [InboxMessageID] +sendTestEmail token i = fmap (fmap asText) . genericSendEmail (Just i) token + +-- | Unified implementation for sending testing and production e-mails. +genericSendEmail :: FromJSON a => Maybe InboxID -> Token -> Email -> IO [a] +genericSendEmail minbox token email = + let url = case minbox of + Nothing -> "send.api.mailtrap.io" + _ -> "sandbox.api.mailtrap.io" + path = case minbox of + Just (InboxID i) -> fromString $ "/api/send/" ++ show i + Nothing -> "/api/send" + in fromJSONResp @"message_ids" <$> genericQuery "POST" url path token multipleErrors (Just email)