diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2019 Jappie Klooster + +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/Readme.md b/Readme.md new file mode 100644 --- /dev/null +++ b/Readme.md @@ -0,0 +1,8 @@ +# Email pool + +Preconfigured email connection pool on top of smtp. + +I needed this in another long term project so I opensourced it. +Support gauranteed (by virtue of usage). + +See example executable for usage. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/mail.hs b/app/mail.hs new file mode 100644 --- /dev/null +++ b/app/mail.hs @@ -0,0 +1,42 @@ +-- | mail +module Main where + +import Network.Mail.Mime +import Network.Mail.Pool +import Options.Applicative + +main :: IO () +main = do + smtp <- readSettings + putStrLn "smtp settings:" + print smtp + settings <- defSmtpPool smtp + sendEmail settings email + where + email = + (emptyMail + Address + {addressName = Just "beterjappie", addressEmail = "beterjappie@raster.click"}) + { mailTo = + [ Address + { addressName = Just "jappie" + , addressEmail = "jappieklooster@hotmail.com" + } + ] + , mailHeaders = + [ ("Subject", "geweldig raster -- Raster") + , ("Reply-To", "superpwnzormegaman@gmail.com") + ] + , mailParts = + [ [ plainPart + "Hello there, I'd like you to introduce you to rater.click. Click here for a quick demo. Or click here to unsubscribe." + ] + ] + } + +readSettings :: IO SmtpCred +readSettings = + customExecParser (prefs showHelpOnError) $ + info + (helper <*> emailOptions) + (fullDesc <> Options.Applicative.header "Email" <> progDesc "Send an email") diff --git a/mail-pool.cabal b/mail-pool.cabal new file mode 100644 --- /dev/null +++ b/mail-pool.cabal @@ -0,0 +1,59 @@ +-- This file has been generated from package.yaml by hpack version 0.28.2. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: d66253edc87b55628b42590d0cedfa990eebcdde14cbeb1482bfbb00a40eb41e + +name: mail-pool +version: 1.0.0 +synopsis: Preconfigured email connection pool on top of smtp. +description: Email helper functions with some sane defaults such as a resource pool and cli support +category: Email +author: Jappie Klooster +maintainer: jappieklooster@hotmail.com +copyright: 2019 Jappie Klooster +license: MIT +license-file: LICENSE +build-type: Simple +cabal-version: >= 1.10 +extra-source-files: + LICENSE + Readme.md + +library + exposed-modules: + Network.Mail.Pool + other-modules: + Paths_mail_pool + hs-source-dirs: + src + default-extensions: EmptyCase FlexibleContexts FlexibleInstances InstanceSigs MultiParamTypeClasses LambdaCase MultiWayIf NamedFieldPuns TupleSections DeriveFoldable DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable DerivingStrategies GeneralizedNewtypeDeriving StandaloneDeriving OverloadedStrings TypeApplications + ghc-options: -Wall -Wcompat -Wincomplete-uni-patterns -Wredundant-constraints -Wincomplete-record-updates -Widentities + build-depends: + HaskellNet + , base >=4.7 && <5 + , microlens + , mime-mail + , network + , optparse-applicative + , resource-pool + default-language: Haskell2010 + +executable exe + main-is: mail.hs + other-modules: + Paths_mail_pool + hs-source-dirs: + app + default-extensions: EmptyCase FlexibleContexts FlexibleInstances InstanceSigs MultiParamTypeClasses LambdaCase MultiWayIf NamedFieldPuns TupleSections DeriveFoldable DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable DerivingStrategies GeneralizedNewtypeDeriving StandaloneDeriving OverloadedStrings TypeApplications + ghc-options: -Wall -Wcompat -Wincomplete-uni-patterns -Wredundant-constraints -Wincomplete-record-updates -Widentities -threaded -rtsopts -with-rtsopts=-N + build-depends: + HaskellNet + , base >=4.7 && <5 + , mail-pool + , microlens + , mime-mail + , network + , optparse-applicative + , resource-pool + default-language: Haskell2010 diff --git a/src/Network/Mail/Pool.hs b/src/Network/Mail/Pool.hs new file mode 100644 --- /dev/null +++ b/src/Network/Mail/Pool.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE DeriveAnyClass #-} + +module Network.Mail.Pool( + module Network.Mail.Pool, + module X + ) where + +import Control.Exception +import Control.Monad.IO.Class +import Data.Pool as X +import Lens.Micro +import Network.HaskellNet.SMTP as X +import Network.Mail.Mime +import Network.Socket +import Options.Applicative +import Type.Reflection (Typeable) + +-- | Failed to authetnicate with some upstream service (smtp for example) +newtype ServiceAuthFailure a = ServiceAuthFailure a + deriving (Typeable, Show) + deriving anyclass Exception + +-- | We use smtp because it's an incredibly stable and well supported protocol +-- this prevents vendorlocking. +data SmtpCred = SmtpCred + { _smtpPassword :: String + , _smtpLogin :: String + , _smtpHost :: String + , _smtpPort :: PortNumber + } deriving (Show) + +smtpHost :: Lens' SmtpCred String +smtpHost = lens _smtpHost (\a b -> a{_smtpHost= b}) +smtpLogin :: Lens' SmtpCred String +smtpLogin = lens _smtpLogin (\a b -> a{_smtpLogin= b}) +smtpPassword :: Lens' SmtpCred String +smtpPassword = lens _smtpPassword (\a b -> a{_smtpPassword= b}) +smtpPort :: Lens' SmtpCred PortNumber +smtpPort = lens _smtpPort (\a b -> a{_smtpPort= b}) + + +defSmtpPool :: MonadIO m => SmtpCred -> m (Pool SMTPConnection) +defSmtpPool smtp = do + liftIO $ + createPool + (authAndConnect smtp) + closeSMTP + 1 -- stripe, see docs, I think I just need 1: https://hackage.haskell.org/package/resource-pool-0.2.3.2/docs/Data-Pool.html + 60 -- unused connections are kept open for a minute + 5 -- max. 10 connections open per stripe + +handleAny :: (SomeException -> IO a) -> IO a -> IO a +handleAny = handle + +-- | we need to auth only once per connection. +-- this is annoying because we want to crash on failure to auth. +authAndConnect :: SmtpCred -> IO SMTPConnection +authAndConnect smtp = do + conn <- connectSMTPPort (smtp ^. smtpHost) (smtp ^. smtpPort) + handleAny + (\ex -> do + closeSMTP conn -- don't leak + throwIO ex) $ do + isSuccess <- + authenticate LOGIN (smtp ^. smtpLogin) (smtp ^. smtpPassword) conn + if isSuccess + then pure conn + else throwIO $ + ServiceAuthFailure $ + smtpPassword .~ "obfuscated, see the running instance CLI" $ smtp + +emailOptions :: Parser SmtpCred +emailOptions = + SmtpCred <$> + strOption + (long "smtp-pass" <> metavar "SMTP-PASS" <> + help + "the smtp password, in case of mailjet: https://app.mailjet.com/transactional/smtp") <*> + strOption + (long "smtp-login" <> metavar "SMTP-LOGIN" <> + help + "the smtp login name, in case of mailjet: https://app.mailjet.com/transactional/smtp") <*> + strOption + (long "smtp-host" <> metavar "SMTP-HOST" <> value "in-v3.mailjet.com" <> + showDefault <> + help "the smtp host, excluding port") <*> + option + auto + (long "smtp-port" <> help "The port on which the smtp server listens" <> + showDefault <> + value 587 <> + metavar "SMTP-PORT") + +sendEmail :: MonadIO m => Pool SMTPConnection -> Mail -> m () +sendEmail pool = liftIO . withResource pool . sendMimeMail2