diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for mailgun + +## 0.2 -- 2019-05-06 + +* Complete rewrite supporting v3 API. diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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. diff --git a/mailgun.cabal b/mailgun.cabal --- a/mailgun.cabal +++ b/mailgun.cabal @@ -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 diff --git a/src/Network/Mail/Mailgun.hs b/src/Network/Mail/Mailgun.hs new file mode 100644 --- /dev/null +++ b/src/Network/Mail/Mailgun.hs @@ -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 diff --git a/src/Network/Mail/Mailgun/API.hs b/src/Network/Mail/Mailgun/API.hs new file mode 100644 --- /dev/null +++ b/src/Network/Mail/Mailgun/API.hs @@ -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) diff --git a/src/Network/Mail/Mailgun/Config.hs b/src/Network/Mail/Mailgun/Config.hs new file mode 100644 --- /dev/null +++ b/src/Network/Mail/Mailgun/Config.hs @@ -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 diff --git a/src/Network/Mail/Mailgun/Domains.hs b/src/Network/Mail/Mailgun/Domains.hs new file mode 100644 --- /dev/null +++ b/src/Network/Mail/Mailgun/Domains.hs @@ -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 diff --git a/src/Network/Mail/Mailgun/List.hs b/src/Network/Mail/Mailgun/List.hs new file mode 100644 --- /dev/null +++ b/src/Network/Mail/Mailgun/List.hs @@ -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) diff --git a/src/Network/Mail/Mailgun/Send.hs b/src/Network/Mail/Mailgun/Send.hs new file mode 100644 --- /dev/null +++ b/src/Network/Mail/Mailgun/Send.hs @@ -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) diff --git a/src/Rackspace/MailGun.hs b/src/Rackspace/MailGun.hs deleted file mode 100644 --- a/src/Rackspace/MailGun.hs +++ /dev/null @@ -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 diff --git a/test/Send.hs b/test/Send.hs deleted file mode 100644 --- a/test/Send.hs +++ /dev/null @@ -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 diff --git a/test/SendMany.hs b/test/SendMany.hs deleted file mode 100644 --- a/test/SendMany.hs +++ /dev/null @@ -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