mailtrap (empty) → 0.1.0.0
raw patch · 5 files changed
+525/−0 lines, 5 filesdep +aesondep +basedep +base64
Dependencies added: aeson, base, base64, blaze-html, bytestring, email-validate, filepath, http-conduit, mime-types, text, time, unordered-containers, uuid-types
Files
- changelog.md +2/−0
- license +21/−0
- mailtrap.cabal +29/−0
- readme.md +8/−0
- src/Network/Mail/Mailtrap.hs +465/−0
+ changelog.md view
@@ -0,0 +1,2 @@+## 0.1.0.0+* First release.
+ license view
@@ -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.
+ mailtrap.cabal view
@@ -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
+ readme.md view
@@ -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.
+ src/Network/Mail/Mailtrap.hs view
@@ -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)