mailgun 0.1.0.4 → 0.2
raw patch · 12 files changed
+807/−196 lines, 12 filesdep +aesondep +aeson-filthydep +asciidep −conduitdep −failuredep −http-clientdep ~basedep ~bytestringdep ~exceptionsnew-uploader
Dependencies added: aeson, aeson-filthy, ascii, containers, filepath, ini, lens, lens-aeson, machines, mime-mail, mime-types, mtl, these, time, unordered-containers, wreq
Dependencies removed: conduit, failure, http-client, http-client-multipart, http-conduit, mailgun, monad-control, network
Dependency ranges changed: base, bytestring, exceptions, text, transformers
Files
- CHANGELOG.md +5/−0
- LICENSE +26/−17
- mailgun.cabal +51/−49
- src/Network/Mail/Mailgun.hs +11/−0
- src/Network/Mail/Mailgun/API.hs +126/−0
- src/Network/Mail/Mailgun/Config.hs +147/−0
- src/Network/Mail/Mailgun/Domains.hs +106/−0
- src/Network/Mail/Mailgun/List.hs +176/−0
- src/Network/Mail/Mailgun/Send.hs +159/−0
- src/Rackspace/MailGun.hs +0/−76
- test/Send.hs +0/−23
- test/SendMany.hs +0/−31
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for mailgun++## 0.2 -- 2019-05-06++* Complete rewrite supporting v3 API.
LICENSE view
@@ -1,21 +1,30 @@-The MIT License (MIT)+Copyright (c) 2019, davean -Copyright (c) 2014 Andrew Rademacher+All rights reserved. -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:+Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met: -The above copyright notice and this permission notice shall be included in-all copies or substantial portions of the Software.+ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer. -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.+ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of davean nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
mailgun.cabal view
@@ -1,55 +1,57 @@+cabal-version: 2.2+ name: mailgun-version: 0.1.0.4-synopsis: Connector to Rackspace's Mailgun Service-description: Allows users to directly access Rackspace's Mailgun service- without having to work with the underlying REST service.-license: MIT+version: 0.2+synopsis: API binding for Mailgun+description:+ API binding for mailgun in Haskell. Primarily the v3 API.+ .+ As of version 0.2, this package was entirely rewriten. Previous versions were developed by Andrew Rademacher.+homepage: https://oss.xkcd.com/+license: BSD-3-Clause license-file: LICENSE-author: Andrew Rademacher-maintainer: andrewrademacher@gmail.com-category: Web-build-type: Simple-cabal-version: >=1.10--homepage: https://github.com/AndrewRademacher/mailgun-bug-reports: https://github.com/AndrewRademacher/mailgun/issues+author: davean+maintainer: oss@xkcd.com+copyright: Copyright (C) 2019 davean+category: Web, Email+extra-source-files: CHANGELOG.md source-repository head- type: git- location: https://github.com/AndrewRademacher/mailgun.git--library- ghc-options: -Wall- exposed-modules: Rackspace.MailGun - hs-source-dirs: src - default-language: Haskell2010- build-depends: base >=4.6 && <4.7- , text >=1.1.0.1- , conduit >=1.1.0- , http-conduit >=2.0.0.8- , bytestring >=0.10.0.2- , network >=2.4.2.2- , http-client-multipart >=0.2.0.0- , transformers >=0.3.0.0- , monad-control >=0.3.2.3- , http-client >=0.2.2.4- , failure >=0.2.0.2- , exceptions >=0.5+ type: git+ location: https://code.xkrd.net/haskell/mailgun.git -executable send- main-is: Send.hs- hs-source-dirs: test- default-language: Haskell2010- build-depends: base >=4.6 && <4.7- , text >=1.1.0.1- , mailgun+common deps+ build-depends:+ aeson ^>= 1.4+ , aeson-filthy ^>= 0.1.3+ , ascii ^>= 0.0+ , base ^>= 4.12.0.0+ , bytestring ^>= 0.10+ , containers ^>= 0.6+ , exceptions ^>= 0.10+ , filepath ^>= 1.4+ , ini ^>= 0.4+ , lens ^>= 4.17+ , lens-aeson ^>= 1.0+ , machines ^>= 0.6+ , mime-mail ^>= 0.5+ , mime-types ^>= 0.1+ , mtl ^>= 2.2+ , text ^>= 1.2+ , these ^>= 0.8+ , time ^>= 1.8+ , transformers ^>= 0.5+ , unordered-containers ^>= 0.2+ , wreq ^>= 0.5 -executable sendmany- main-is: SendMany.hs- hs-source-dirs: test- default-language: Haskell2010- build-depends: base >=4.6 && <4.7- , text >=1.1.0.1- , http-conduit >=2.0.0.8- , transformers >=0.3.0.0- , mailgun+library+ import: deps+ hs-source-dirs: src+ default-language: Haskell2010+ exposed-modules:+ Network.Mail.Mailgun+ Network.Mail.Mailgun.API+ Network.Mail.Mailgun.Config+ Network.Mail.Mailgun.Domains+ Network.Mail.Mailgun.List+ Network.Mail.Mailgun.Send
+ src/Network/Mail/Mailgun.hs view
@@ -0,0 +1,11 @@+module Network.Mail.Mailgun+ ( module Network.Mail.Mailgun.Config+ , module Network.Mail.Mailgun.Domains+ , module Network.Mail.Mailgun.List+ , module Network.Mail.Mailgun.Send+ ) where++import Network.Mail.Mailgun.Config+import Network.Mail.Mailgun.Domains+import Network.Mail.Mailgun.List+import Network.Mail.Mailgun.Send
+ src/Network/Mail/Mailgun/API.hs view
@@ -0,0 +1,126 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+module Network.Mail.Mailgun.API where++import Control.Lens+import Control.Monad.Catch+import Control.Monad.Reader.Class+import Control.Monad.Trans+import qualified Data.Aeson as JS+import Data.Aeson.Lens+import Data.Foldable+import Data.Machine+import Network.Mail.Mailgun.Config+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import Network.Wreq+import Network.Wreq.Types (Postable)+import qualified Network.Wreq as HTTP+import Text.Printf++data UnparsableResponse+ = UnparsableResponse JS.Value+ deriving (Show)++makePrisms ''UnparsableResponse+instance Exception UnparsableResponse++data MailgunApiError+ = RequestTooLarge+ | MailgunSideError+ | MailgunNotFound+ | UnknownResponseError Int+ deriving (Show)++makePrisms ''MailgunApiError+instance Exception MailgunApiError++data MGRequest+ = MGGet+ { _reqPath :: DomainName -> String+ , _reqParams :: [(Text, Text)]+ }+ | MGDelete+ { _reqPath :: DomainName -> String+ , _reqParams :: [(Text, Text)]+ }+ | forall b. Postable b => MGPost+ { _reqPath :: DomainName -> String+ , _reqParams :: [(Text, Text)]+ , _reqBody :: b+ }++makeLenses ''MGRequest++yesNo :: Text -> Bool -> HTTP.Part+yesNo t True = partText t "yes"+yesNo t False = partText t "no"++wreqOptions :: MailgunConfig -> Options+wreqOptions = reader $ \c ->+ defaults & auth ?~ basicAuth (TE.encodeUtf8 "api") (c^.mailgunApiKey)++call :: forall c m r+ . (HasMailgunConfig c, MonadIO m, MonadThrow m, MonadReader c m)+ => MGRequest+ -> (JS.Value -> Maybe r)+ -> m r+call rq respHandle = do+ c <- view mailgunConfig+ let o = (c^.to wreqOptions) & params .~ (rq^.reqParams) & checkResponse .~ (Just $ \_ _ -> pure ())+ let url = mconcat ["https://", c^.mailgunApiDomain, (rq^.reqPath) (c^.mailgunDomain)]+ resp <- liftIO $ case rq of+ MGGet {} ->+ getWith o url+ MGDelete {} ->+ deleteWith o url+ MGPost {_reqBody=bdy} ->+ postWith o url bdy+ case resp^.responseStatus.statusCode of+ 404 -> throwM MailgunNotFound+ 413 -> throwM RequestTooLarge+ sts | sts `elem` [500, 502, 503, 504] -> throwM MailgunSideError+ 200 -> do+ vr <- asValue resp+ case respHandle (vr^.responseBody) of+ Nothing -> throwM $ UnparsableResponse (vr^.responseBody)+ Just r -> pure r+ sts -> throwM $ UnknownResponseError sts++getStream :: forall t c m r s+ . (HasMailgunConfig c, MonadIO m, MonadThrow m, MonadReader c m)+ => s+ -- ^ The initial start parameter (like @begin@)+ -> (s -> (t, MGRequest))+ -> (t -> JS.Value -> Maybe (Maybe s, [r]))+ -> SourceT m r+getStream seed rqMkr respHandle = construct (go seed)+ where+ go r = do+ let (c, rq) = rqMkr r+ (ms, res) <- lift $ call rq (respHandle c)+ for_ res yield+ for_ ms go++paginatedStream :: forall c m r+ . (HasMailgunConfig c, MonadIO m, MonadThrow m, MonadReader c m)+ => MGRequest -> (JS.Value -> Maybe [r]) -> SourceT m r+paginatedStream rq respHandle = preplan $ do+ dmn <- lift $ view mailgunApiDomain+ let upre = T.pack $ printf "https://%s" dmn+ pure $ getStream Nothing+ (\case+ Nothing -> ((), rq)+ Just s ->+ ((), MGGet (const . maybe (error "no url pre") T.unpack .+ T.stripPrefix upre $ s) []))+ (\() j -> let mr = respHandle j+ in fmap (\case+ [] -> (Nothing, [])+ r -> (j^?key "paging".key "next"._JSON, r)) mr)
+ src/Network/Mail/Mailgun/Config.hs view
@@ -0,0 +1,147 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+module Network.Mail.Mailgun.Config+ ( DomainName+ , MailgunConfig(..)+ , HasMailgunConfig(..)+ , mailgunGetConfig+ , mailgunFromEnv, mailgunFromIni+ , MailgunConfigException(..)+ , _MailgunApiKeyRequired, _MailgunDomainRequired+ , _MailgunInvalidRegion, _MailgunIniNotFound+ , _MailgunConextUnavailable+ ) where++import Control.Applicative+import Control.Lens+import Control.Monad.Catch+import Control.Monad.Trans+import Control.Monad.Trans.Maybe+import qualified Data.ByteString as BS+import Data.Foldable+import Data.Ini+import Data.Maybe+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import System.Environment+import System.FilePath++data MailgunConfigException+ = MailgunApiKeyRequired+ | MailgunDomainRequired+ | MailgunInvalidRegion+ | MailgunIniNotFound+ | MailgunConextUnavailable+ deriving (Show)++instance Exception MailgunConfigException++makePrisms ''MailgunConfigException++type DomainName = String++-- | The configuration we use when accessing the Mailgun API.+data MailgunConfig+ = MailgunConfig+ { _mailgunDomain :: DomainName+ -- ^ The domain we're using mailgun with.+ , _mailgunApiKey :: BS.ByteString+ -- ^ Our mailgun API key.+ , _mailgunApiDomain :: String+ -- ^ The base URL for the mailgun API, usually "https://api.mailgun.net"+ , _mailgunTestMode :: Bool+ }+ deriving (Show, Eq)++makeClassy ''MailgunConfig++-- | The domain for the API URL used for the US region.+usApiDomain :: String+usApiDomain = "api.mailgun.net"++-- | The domain for the API URL used for the EU region.+euApiDomain :: String+euApiDomain = "api.eu.mailgun.net"++-- | Uses the available options to discover a MaingunConfig if possible.+mailgunGetConfig :: (MonadIO m, MonadCatch m) => m MailgunConfig+mailgunGetConfig = do+ ec <- runMaybeT . msum .+ map (\act -> act `catch` (\(_::MailgunConfigException) -> MaybeT $ pure Nothing)) $+ [ mailgunFromEnv+ , mailgunFromIni+ ]+ maybe (throwM MailgunConextUnavailable) pure ec++-- | Builds a MaingunConfig from enviromental variables.+--+-- MAILGUN_API_KEY: Required; the API key for mailgun.+-- MAILGUN_DOMAIN: Required; the domain in mailgun we're using.+-- MAILGUN_REGION: Optional; Selects teh regional API endpoint.+-- Valid values are 'US', and 'EU', defaults to 'US'.+-- MAILGUN_API_BASE: Optional; Override the base URL (primarily for testing).+-- Takes presidence over MAILGUN_REGION.+-- MAILGUN_LIVE: Optional: Unless set to True, set to test mode.+-- In test mode Mailgun accepts but does not send messages. +mailgunFromEnv :: (MonadIO m, MonadThrow m) => m MailgunConfig+mailgunFromEnv = do+ apiKey <- maybe (throwM MailgunApiKeyRequired) (pure . TE.encodeUtf8 . T.pack) =<<+ liftIO (lookupEnv "MAILGUN_API_KEY")+ domain <- maybe (throwM MailgunDomainRequired) pure =<<+ liftIO (lookupEnv "MAILGUN_DOMAIN")+ testmode <- ((Just "True")==) <$> liftIO (lookupEnv "MAILGUN_DOMAIN")+ apiDomain <- liftIO (lookupEnv "MAILGUN_API_BASE") >>= \case+ Just ab -> pure ab+ Nothing ->+ liftIO (lookupEnv "MAILGUN_REGION") >>= \case+ Nothing -> pure usApiDomain+ Just "US" -> pure usApiDomain+ Just "EU" -> pure euApiDomain+ _ -> throwM MailgunInvalidRegion+ pure $ MailgunConfig domain apiKey apiDomain testmode++-- | Looks for an ini format file at ".mailgun" and "~/.mailgun" in that order.+-- Credentials are read from the ini in the format:+-- @+-- [mailgun]+-- region: US+-- domain: mydomain.com+-- key: 3ax6xnjp29jd6fds4gc373sgvjxteol0+-- api_domain: api.mailgun.com+-- live: True+-- @+--+-- The API key and domain are required, other values are optional.+mailgunFromIni :: forall m . (MonadIO m, MonadThrow m) => m MailgunConfig+mailgunFromIni = do+ ini <- (maybe (throwM MailgunIniNotFound) pure . asum) =<<+ liftIO (sequence+ [ readIniFileMay ".mailgun"+ , lookupEnv "HOME" >>=+ maybe (pure Nothing) (\h -> readIniFileMay (h </> ".mailgun"))+ ])+ apiKey <- TE.encodeUtf8 . T.pack <$> lookupMailgun MailgunApiKeyRequired ini "key"+ domain <- lookupMailgun MailgunApiKeyRequired ini "domain"+ let testmode = (Just "True") == lookupMailgunMay ini "live"+ let apiDomain = fromMaybe usApiDomain $+ (lookupMailgunMay ini "api_domain")+ <|> ((\case+ "US" -> usApiDomain+ "EU" -> euApiDomain+ _ -> usApiDomain)+ <$> (lookupMailgunMay ini "region"))+ pure $ MailgunConfig domain apiKey apiDomain testmode+ where+ readIniFileMay :: FilePath -> IO (Maybe Ini)+ readIniFileMay fp = (maybeRight <$> readIniFile fp) `catchIOError` (const (pure Nothing))+ lookupMailgun :: MailgunConfigException -> Ini -> Text -> m String+ lookupMailgun e ini key = maybe (throwM e) pure $ lookupMailgunMay ini key+ lookupMailgunMay :: Ini -> Text -> Maybe String+ lookupMailgunMay ini key =+ either (const Nothing) (Just . T.unpack) $ lookupValue "mailgun" key ini+ maybeRight :: Either a b -> Maybe b+ maybeRight (Left _) = Nothing+ maybeRight (Right b) = Just b
+ src/Network/Mail/Mailgun/Domains.hs view
@@ -0,0 +1,106 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+module Network.Mail.Mailgun.Domains where++import Control.Lens+import Control.Monad.Catch+import Control.Monad.Reader.Class+import Control.Monad.Trans+import qualified Data.Aeson as JS+import Data.Aeson ((.:))+import Data.Aeson.Filthy+import Data.Aeson.Lens+import Data.Machine+import Data.Text (Text)+import qualified Data.Text as T+import Data.Time+import Network.Mail.Mailgun.API+import Network.Mail.Mailgun.Config++data SpamAction+ = SpamDisabled+ | SpamBlock+ | SpamTag+ deriving (Show, Eq, Ord)++makePrisms ''SpamAction++instance JS.FromJSON SpamAction where+ parseJSON = JS.withText "SpamAction" $ \case+ "disabled" -> pure SpamDisabled+ "block" -> pure SpamBlock+ "tag" -> pure SpamTag+ s -> fail $ "Unknown SpamAction "++show s++instance JS.ToJSON SpamAction where+ toJSON SpamDisabled = JS.String "disabled"+ toJSON SpamBlock = JS.String "block"+ toJSON SpamTag = JS.String "tag"++data DomainType+ = CustomDomain+ | SandboxDomain+ deriving (Show, Eq, Ord)++makePrisms ''DomainType++instance JS.FromJSON DomainType where+ parseJSON = JS.withText "DomainType" $ \case+ "custom" -> pure CustomDomain+ "sandbox" -> pure SandboxDomain+ t -> fail $ "Unknown DomainType "++show t++instance JS.ToJSON DomainType where+ toJSON CustomDomain = JS.String "custom"+ toJSON SandboxDomain = JS.String "sandbox"++data Domain+ = Domain+ { _domainCreated :: UTCTime+ , _domainSmtpLogin :: Text+ , _domainSmtpPass :: Text+ , _domainName :: Text+ , _domainWildcard :: Bool+ , _domainSpamAction :: SpamAction+ , _domainActive :: Bool+ , _domainType :: DomainType+ }+ deriving (Show)++makeClassy ''Domain++instance JS.FromJSON Domain where+ parseJSON = JS.withObject "Domain" $ \v -> Domain+ <$> (fromRFC2822Time <$> v .: "created_at")+ <*> v .: "smtp_login"+ <*> v .: "smtp_password"+ <*> v .: "name"+ <*> v .: "wildcard"+ <*> v .: "spam_action"+ <*> ((==("active"::Text)) <$> v .: "state")+ <*> v .: "type"++instance JS.ToJSON Domain where+ toJSON d = JS.object+ [("created_at", d^.domainCreated.(to RFC2822Time).to JS.toJSON)+ ,("smtp_login", d^.domainSmtpLogin.to JS.toJSON)+ ,("smtp_password", d^.domainSmtpPass.to JS.toJSON)+ ,("name", d^.domainName.to JS.toJSON)+ ,("wildcard", d^.domainWildcard.to JS.toJSON)+ ,("spam_action", d^.domainSpamAction.to JS.toJSON)+ ,("state", JS.String $ if d^.domainActive then "active" else "unverified")+ ,("type", d^.domainType.to JS.toJSON)+ ]++getDomains :: (HasMailgunConfig c, MonadIO m, MonadThrow m, MonadReader c m) => SourceT m Domain+getDomains =+ getStream 0+ (\skip -> (skip, MGGet (const "/v3/domains") [("skip", T.pack $ show skip)+ ,("limit", T.pack $ show pagingSize)]))+ (\skipped respVal ->+ let mrs = respVal^?key "items"._JSON+ in fmap (\rs -> (if length rs == pagingSize then Just (skipped+length rs) else Nothing+ ,rs)) mrs)+ where+ pagingSize = 500
+ src/Network/Mail/Mailgun/List.hs view
@@ -0,0 +1,176 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-}+module Network.Mail.Mailgun.List where++import Control.Lens+import Control.Monad.Catch+import Control.Monad.Reader+import Data.Aeson ((.:))+import qualified Data.Aeson as JS+import Data.Aeson.Lens+import Data.Aeson.Filthy+import Data.Machine+import qualified Data.Proxy as Proxy+import Data.Text+import Data.Time+import Network.Mail.Mailgun.API+import Network.Mail.Mailgun.Config+import Network.Wreq+import Text.Printf++data AccessLevel+ = AccessReadonly+ | AccessMembers+ | AccessEveryone+ deriving (Eq, Ord, Show)++encodeAccessLevel :: AccessLevel -> Text+encodeAccessLevel AccessReadonly = "readonly"+encodeAccessLevel AccessMembers = "members"+encodeAccessLevel AccessEveryone = "everyone"++instance JS.FromJSON AccessLevel where+ parseJSON = JS.withText "AccessLevel" $ \case+ "readonly" -> pure AccessReadonly+ "members" -> pure AccessMembers+ "everyone" -> pure AccessEveryone+ t -> fail $ "Unknown AccessLevel "++show t++instance JS.ToJSON AccessLevel where+ toJSON = JS.String . encodeAccessLevel++data MailingList f+ = MailingList+ { _listAccessLevel :: AccessLevel+ , _listAddress :: Text+ , _listName :: Text+ , _listDescription :: Text+ , _listCreated :: f UTCTime+ , _listMemberCount :: f Integer+ }++makeLenses ''MailingList++instance Show (MailingList Identity) where+ show (MailingList al a n d c mc) =+ printf "MailingList %s %s %s %s %s %s"+ (show al) a n d (show c) (show mc)++instance Applicative f => JS.FromJSON (MailingList f) where+ parseJSON = JS.withObject "MailingList" $ \v -> MailingList+ <$> v .: "access_level"+ <*> v .: "address"+ <*> v .: "name"+ <*> v .: "description"+ <*> (pure . fromRFC2822Time <$> v .: "created_at")+ <*> (pure <$> v .: "members_count")++instance JS.ToJSON (MailingList Identity) where+ toJSON ml = JS.object+ [ ("access_level", ml^.listAccessLevel.to JS.toJSON)+ , ("address", ml^.listAddress.to JS.toJSON)+ , ("name", ml^.listName.to JS.toJSON)+ , ("description", ml^.listDescription.to JS.toJSON)+ , ("created_at", ml^.listCreated.to (RFC2822Time . runIdentity).to JS.toJSON)+ , ("members_count", ml^.listMemberCount.to runIdentity.to JS.toJSON)+ ]++instance JS.ToJSON (MailingList Proxy.Proxy) where+ toJSON ml = JS.object+ [ ("access_level", ml^.listAccessLevel.to JS.toJSON)+ , ("address", ml^.listAddress.to JS.toJSON)+ , ("name", ml^.listName.to JS.toJSON)+ , ("description", ml^.listDescription.to JS.toJSON)+ ]++data ListMember v+ = ListMember+ { _lmName :: Text+ , _lmAddress :: Text+ , _lmSubscribed :: Bool+ , _lmExtra :: v+ }+ deriving (Eq, Ord, Show)++makeLenses ''ListMember++instance JS.FromJSON v => JS.FromJSON (ListMember v) where+ parseJSON = JS.withObject "MailingList" $ \v -> ListMember+ <$> v .: "name"+ <*> v .: "address"+ <*> v .: "subscribed"+ <*> v .: "vars"++instance JS.ToJSON v => JS.ToJSON (ListMember v) where+ toJSON lm = JS.object+ [ ("name", lm^.lmName.to JS.toJSON)+ , ("address", lm^.lmAddress.to JS.toJSON)+ , ("subscribed", lm^.lmSubscribed.to JS.toJSON)+ , ("vars", lm^.lmExtra.to JS.toJSON)+ ]++createList :: (HasMailgunConfig c, MonadReader c m, MonadIO m, MonadThrow m)+ => MailingList Proxy.Proxy -> m ()+createList ml =+ call (MGPost (const "/v3/lists") []+ [ partText "address" (ml^.listAddress)+ , partText "name" (ml^.listName)+ , partText "description" (ml^.listDescription)+ , partText "access_level" (ml^.listAccessLevel.to encodeAccessLevel)+ ])+ (const $ Just ())++getLists :: (HasMailgunConfig c, MonadReader c m, MonadIO m, MonadThrow m)+ => SourceT m (MailingList Identity)+getLists = paginatedStream (MGGet (const "/v3/lists/pages") []) (^.key "items"._JSON)++getList :: (HasMailgunConfig c, MonadReader c m, MonadIO m, MonadThrow m)+ => Text -> m (MailingList Identity)+getList addr =+ call (MGGet (const $ printf "/v3/lists/%s" addr) [])+ (^?key "list"._JSON)++removeList :: (HasMailgunConfig c, MonadReader c m, MonadIO m, MonadThrow m)+ => Text -> m ()+removeList ml =+ call (MGDelete (const $ printf "/v3/lists/%s" ml) [])+ (const $ Just ())++listMembers :: (JS.ToJSON v, JS.FromJSON v+ ,HasMailgunConfig c, MonadReader c m, MonadIO m, MonadThrow m)+ => Maybe Bool -> Text -> SourceT m (ListMember v)+listMembers msubbed ml =+ paginatedStream (MGGet (const $ printf "/v3/lists/%s/members/pages" ml) . mconcat $+ [ maybe [] (\s -> [("subscribed", if s then "yes" else "no")]) msubbed+ , [ ("limit", "1000") ]+ ])+ (^.key "items"._JSON)++getMember :: (JS.ToJSON v, JS.FromJSON v+ ,HasMailgunConfig c, MonadReader c m, MonadIO m, MonadThrow m)+ => Text -> Text -> m (ListMember v)+getMember ml mbr =+ call (MGGet (const $ printf "/v3/lists/%s/members/%s" ml mbr) [])+ (^?key "member"._JSON)++removeMember :: (HasMailgunConfig c, MonadReader c m, MonadIO m, MonadThrow m)+ => Text -> Text -> m ()+removeMember ml mbr =+ call (MGDelete (const $ printf "/v3/lists/%s/members/%s" ml mbr) [])+ (const $ Just ())++addMembers :: (JS.ToJSON v, JS.FromJSON v+ ,HasMailgunConfig c, MonadReader c m, MonadIO m, MonadThrow m)+ => Bool -> Text -> ProcessT m (ListMember v) (MailingList Identity)+addMembers upsert ml =+ buffered 1000 ~> addMemberBatch+ where+ addMemberBatch = autoM $ \batch -> do+ call (MGPost (const $ printf "/v3/lists/%s/members.json" ml) []+ [ yesNo "upsert" upsert+ , partLBS "members" $ JS.encode batch+ ])+ (^?key "list"._JSON)
+ src/Network/Mail/Mailgun/Send.hs view
@@ -0,0 +1,159 @@+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+module Network.Mail.Mailgun.Send+ ( MessageID, MailgunTags+ , ClickTrack(..), _DoTrackClick, _DontTrackClick, _TrackClickHtmlOnly+ , MailgunSendOptions(..)+ , tags, dkim, deliverAt, track, trackClicks, trackOpens, templateVariables+ , send+ , sending+ ) where++import Control.Lens+import Control.Monad.Catch+import Control.Monad.Reader+import qualified Data.Aeson as JS+import Data.Aeson.Lens+import Data.Ascii (CIAscii)+import qualified Data.Ascii as ASCII+import qualified Data.ByteString.Lazy as BSL+import Data.Machine+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Text (Text)+import qualified Data.Text as T+import Data.These+import Data.Time+import Network.Mail.Mailgun.API+import Network.Mail.Mailgun.Config+import Network.Mail.Mime (Address, addressEmail, Mail, renderMail', renderAddress)+import Network.Mime+import Network.Wreq+import qualified Network.Wreq as HTTP+import Text.Printf++type MessageID = Text++-- | 0 to 3 entries+type MailgunTags = [CIAscii]++data ClickTrack+ = DoTrackClick+ | DontTrackClick+ | TrackClickHtmlOnly+ deriving (Show, Eq, Ord)++makePrisms ''ClickTrack++clickTrackFormPart :: ClickTrack -> HTTP.Part+clickTrackFormPart DoTrackClick = partText "o:tracking-clicks" "yes"+clickTrackFormPart DontTrackClick = partText "o:tracking-clicks" "no"+clickTrackFormPart TrackClickHtmlOnly = partText "o:tracking-clicks" "htmlonly"++data MailgunSendOptions+ = MSO+ { _tags :: MailgunTags+ , _dkim :: Bool+ , _deliverAt :: Maybe UTCTime+ , _track :: Bool+ , _trackClicks :: ClickTrack+ , _trackOpens :: Bool+ , _templateVariables :: Map Text JS.Value+ }+ deriving (Show)++makeClassy ''MailgunSendOptions++mgsoAsMultipart :: Bool -> Maybe MailgunSendOptions -> [HTTP.Part]+mgsoAsMultipart test mo = mconcat $+ [ [yesNo "o:testmode" test]+ , maybe [] (\o -> mconcat+ [ o^..tags.each.to (partBS "o:tag" . ASCII.ciToByteString)+ , [partText "o:dkim" (if o^.dkim then "yes" else "no")]+ , o^..deliverAt.each.to (partString "o:deliverytime" .+ formatTime defaultTimeLocale "%a, %e %b %Y %T %z")+ , [o^.track.to (yesNo "o:tracking")]+ , [o^.trackClicks.to clickTrackFormPart]+ , [o^.trackOpens.to (yesNo "o:tracking-opens")]+ , map (\(k, v) -> partLBS ("v:" `T.append` k) (JS.encode v))+ (o^.templateVariables.to Map.toList)+ ]) mo+ ]++-- | Sends a given email.+send :: (HasMailgunConfig c, MonadIO m, MonadThrow m, MonadReader c m)+ => Maybe MailgunSendOptions -> [Address] -> Mail -> m MessageID+send mo dests m = do+ test <- view mailgunTestMode+ rndrd <- liftIO $! renderMail' m+ call (MGPost (printf "/v3/%s/messages.mime") [] . mconcat $+ [ mgsoAsMultipart test mo+ , [partLBS "message" rndrd & partFileName .~ Just "message.mime"]+ , map (partText "to" . renderAddress) dests+ ]) (^?key "id"._JSON)++{- This has to be the form API, which leaves less control over attachments?+ - Its unclear if the MIME API allows recipient-variables.+ -}++type FromAddress = Address+type CcAddresses = [Address]+type BccAddresses = [Address]+type Subject = Text+type HtmlBody = Text+type TextBody = Text+type InlineAttachments = [Attachment]+type Attachments = [Attachment]+type Attachment = (MimeType, Maybe FileName, BSL.ByteString)++attachmentToMutli :: Bool -> Attachment -> Part+attachmentToMutli inline (contentType, mFileName, body) =+ partLBS (if inline then "inline" else "attachment") body+ & partFileName .~ (fmap T.unpack mFileName)+ & partContentType .~ Just contentType++-- | Takes an email, ignoring the to addresses, and sends it to all the+-- addresses streamed in, paramterized by the JS.Values which can be used+-- in the templating.+sending :: (HasMailgunConfig c, MonadIO m, MonadThrow m, MonadReader c m+ ,JS.ToJSON t)+ => Maybe MailgunSendOptions+ -> FromAddress+ -> CcAddresses+ -> BccAddresses+ -> Subject+ -> These HtmlBody TextBody+ -> InlineAttachments+ -> Attachments+ -> ProcessT m (Address, t) MessageID+sending mo fromAddr ccAddr bccAddr subj theseBodies inline attach =+ buffered 1000 ~> sendBatch+ where+ sendBatch = preplan $ do+ test <- view mailgunTestMode+ let sharedParts = mconcat $+ [ mgsoAsMultipart test mo+ , [partText "from" . renderAddress $ fromAddr]+ , map (partText "cc" . renderAddress) ccAddr+ , map (partText "bcc" . renderAddress) bccAddr+ , [partText "subject" subj]+ , mergeTheseWith+ (pure . partText "html")+ (pure . partText "text")+ (++)+ theseBodies+ , map (attachmentToMutli True) inline+ , map (attachmentToMutli False) attach+ ]+ pure . autoM $ \batch' -> do+ let batch = Map.fromList . map (\tpl@(addr, _) -> (addressEmail addr, tpl)) $ batch'+ call (MGPost (printf "/v3/%s/messages") [] . mconcat $+ [ [partLBS "recipient-variables" . JS.encode .+ JS.toJSON . fmap snd $ batch+ ]+ , (map (partText "to") . map (renderAddress . fst) . Map.elems $ batch)+ , sharedParts+ ])+ (^?key "id"._JSON)
− src/Rackspace/MailGun.hs
@@ -1,76 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TemplateHaskell #-}--module Rackspace.MailGun- ( Message (..)- , sendMessage- , sendWith- ) where--import Control.Monad.Catch-import Control.Monad.IO.Class-import Control.Monad.Trans.Control-import qualified Data.ByteString.Char8 as BS-import qualified Data.ByteString.Lazy.Char8 as LBS-import Data.Text-import Data.Text.Encoding-import Network.HTTP.Client.MultipartFormData-import Network.HTTP.Conduit--baseUrl :: String-baseUrl = "https://api.mailgun.net/v2"--data Message = TextMessage- { from :: Text- , to :: Text- , cc :: Maybe Text- , bcc :: Maybe Text- , subject :: Maybe Text- , text :: Text }- | HtmlMessage- { from :: Text- , to :: Text- , cc :: Maybe Text- , bcc :: Maybe Text- , subject :: Maybe Text- , html :: Text }- deriving (Eq, Show)--partText :: Text -> Text -> [Part]-partText name value = [ partBS name (encodeUtf8 value) ]--partMaybeText :: Text -> Maybe Text -> [Part]-partMaybeText name value = case value of- Just val -> [ partBS name (encodeUtf8 val) ]- Nothing -> []--buildTail :: Message -> [Part]-buildTail TextMessage{..} = partText "text" text-buildTail HtmlMessage{..} = partText "html" html--buildBase :: Message -> [Part]-buildBase msg = partText "from" (from msg)- ++ partText "to" (to msg)- ++ partMaybeText "cc" (cc msg)- ++ partMaybeText "bcc" (bcc msg)- ++ partMaybeText "subject" (subject msg)- ++ buildTail msg--sendMessage :: (MonadIO m, MonadBaseControl IO m, MonadThrow m) =>- String -> String -> Message -> m (Response LBS.ByteString)-sendMessage domain apiKey message = do- withManager $ \manager -> do- sendWith manager domain apiKey message--sendWith :: (MonadIO m, MonadBaseControl IO m, MonadThrow m) =>- Manager -> String -> String -> Message -> m (Response LBS.ByteString)-sendWith manager domain apiKey message = do- initReq <- parseUrl $ baseUrl ++ "/" ++ domain ++ "/messages"- let authReq = applyBasicAuth "api" (BS.pack apiKey) initReq- postReq = authReq { method = "POST" }- res <- flip httpLbs manager =<<- (formDataBody (buildBase message) postReq)- return res
− test/Send.hs
@@ -1,23 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Main where--import Data.Text as T (Text (..), pack)-import Rackspace.MailGun-import System.Environment--main :: IO ()-main = do- domain <- getEnv "MAILGUN_DOMAIN"- apiKey <- getEnv "MAILGUN_SECRET"- testAddr <- getEnv "MAILGUN_TEST_ADDRESS"-- let message = TextMessage- { from = T.pack ("someone@" ++ domain)- , to = T.pack testAddr- , cc = Nothing- , bcc = Nothing- , subject = Just "Test Message"- , text = "Hello, this is a test message!" }- res <- sendMessage domain apiKey message- print res
− test/SendMany.hs
@@ -1,31 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Main where--import Control.Monad.IO.Class-import Data.Text as T (Text (..), pack)-import Network.HTTP.Conduit-import Rackspace.MailGun-import System.Environment--main :: IO ()-main = do- domain <- getEnv "MAILGUN_DOMAIN"- apiKey <- getEnv "MAILGUN_SECRET"- testAddr <- getEnv "MAILGUN_TEST_ADDRESS"-- let message = TextMessage- { from = T.pack ("someone@" ++ domain)- , to = T.pack testAddr- , cc = Nothing- , bcc = Nothing- , subject = Just "Test Message"- , text = "Hello, this is a test message!" }- withManager $ \manager -> do- let sendW = sendWith manager- res1 <- sendW domain apiKey message- res2 <- sendW domain apiKey message- res3 <- sendW domain apiKey message- liftIO $ print res1- liftIO $ print res2- liftIO $ print res3