ehlo (empty) → 0.1.0.0
raw patch · 6 files changed
+489/−0 lines, 6 filesdep +HsOpenSSLdep +attoparsecdep +base
Dependencies added: HsOpenSSL, attoparsec, base, bytestring, hookup, network, text, transformers
Files
- Changelog.md +4/−0
- LICENSE +21/−0
- README.md +26/−0
- ehlo.cabal +49/−0
- lib/Network/SMTP/Client.hs +334/−0
- lib/Network/SMTP/Parser.hs +55/−0
+ Changelog.md view
@@ -0,0 +1,4 @@+[0.1.0.0] -- July 2022+[0.1.0.0]: https://github.com/mordae/ehlo/compare/initial...0.1.0.0++* Initial release
+ LICENSE view
@@ -0,0 +1,21 @@+Copyright (c) 2021 Jan Hamal Dvořák++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.+
+ README.md view
@@ -0,0 +1,26 @@+# ehlo++**Minimalistic SMTP client for Haskell**++It has a single mission:++1. Connect to a SMTP server and setup a secure channel,+2. authenticate, if desired,+3. say `EHLO`, `MAIL FROM`, `RCPT TO` and `DATA`,+4. transmit our email, taking care to properly escape it`.`+5. Finish and `QUIT`.++Usage:++```haskell+let settings = SmtpSettings { smtpHost = "example.org"+ , smtpSender = "mailer.example.org"+ , smtpOverSSL = False+ , smtpSecure = True+ , smtpPort = 587+ , smtpAuth = Just ("login", "password")+ , smtpDebug = False+ }++sendMail settings sender [recipient] email+```
+ ehlo.cabal view
@@ -0,0 +1,49 @@+cabal-version: 3.0+name: ehlo+version: 0.1.0.0+license: MIT+license-file: LICENSE+copyright: Jan Hamal Dvořák+maintainer: mordae@anilinux.org+author: Jan Hamal Dvořák+homepage: https://github.com/mordae/ehlo#readme+bug-reports: https://github.com/mordae/ehlo/issues+synopsis: Minimalistic SMTP client for Haskell+description:+ Minimalistic SMTP client that connects to the remote server,+ establishes secure communication, authenticates and transmits+ a MIME-encoded email message to specified recipients.++category: Network+build-type: Simple+extra-source-files:+ README.md+ Changelog.md++source-repository head+ type: git+ location: https://github.com/mordae/ehlo.git++library+ exposed-modules: Network.SMTP.Client+ hs-source-dirs: lib+ other-modules: Network.SMTP.Parser+ default-language: GHC2021+ default-extensions:+ BlockArguments NoImplicitPrelude OverloadedStrings RecordWildCards+ CPP++ ghc-options:+ -Wall -Wcompat -Wincomplete-uni-patterns+ -Wincomplete-record-updates -Widentities -Wredundant-constraints+ -Wunused-packages++ build-depends:+ attoparsec >=0.14,+ base >=4.13 && <5,+ bytestring >=0.10,+ hookup >=0.6,+ HsOpenSSL >=0.11,+ network >=3.1,+ text >=1.2,+ transformers >=0.5
+ lib/Network/SMTP/Client.hs view
@@ -0,0 +1,334 @@+-- |+-- Module : Network.SMTP.Client+-- Copyright : Jan Hamal Dvořák+-- License : MIT+--+-- Maintainer : mordae@anilinux.org+-- Stability : unstable+-- Portability : non-portable (ghc)+--+-- This module provides means to connect to a SMTP server and submit an email.+--++module Network.SMTP.Client+ ( sendMail+ , defaultSmtpSettings+ , SmtpSettings(..)+ , SmtpResult(..)+ )+where+ import Prelude hiding (lines)++ import Network.SMTP.Parser++ import Data.Typeable+ import GHC.Generics++ import Control.Exception (bracket)+ import Control.Monad.IO.Class (MonadIO, liftIO)+ import Control.Monad.Trans.Reader (ReaderT, runReaderT, ask)+ import Control.Monad (when, unless, forM_)++ import Data.Char (isAscii)+ import Data.Text (Text)++ import Hookup+ import Network.Socket (PortNumber)++ import OpenSSL+ import OpenSSL.EVP.Base64 (encodeBase64BS)++ import qualified Data.ByteString as BS+ import qualified Data.ByteString.Lazy as LBS+ import qualified Data.Text as T+ import qualified Data.Text.Encoding as T+++ -- |+ -- Settings for connecting to the SMTP server.+ --+ data SmtpSettings+ = SmtpSettings+ { smtpHost :: Text+ -- ^ Server to connect to.++ , smtpSender :: Text+ -- ^ Our domain name to use in EHLO.+ -- Better tell truth or risk getting spammer treatment.++ , smtpOverSSL :: Bool+ -- ^ Force SSL instead of trying STARTTLS.++ , smtpSecure :: Bool+ -- ^ Abort if STARTTLS gets rejected.+ -- Better keep this on when MITM attack is a concern.++ , smtpPort :: PortNumber+ -- ^ Port to connect to. Usually either 587 or 465 (SSL).++ , smtpAuth :: Maybe (Text, Text)+ -- ^ Login and password to be used.+ -- Can be skipped for internal servers that whitelist IPs.+ -- Supports only @PLAIN@ authentication method.++ , smtpDebug :: Bool+ -- ^ Print the SMTP exchange (as understood by the client) to stdout.+ }+ deriving (Show, Eq, Typeable, Generic)+++ -- |+ -- Result of the 'sendMail' function.+ --+ data SmtpResult+ = SmtpError Int [BS.ByteString] -- ^ Server has rejected our attempt.+ | SmtpGibberish String -- ^ Failed to parse server reply.+ | SmtpSuccess -- ^ Messages was queued successfully.+ deriving (Show, Eq, Typeable, Generic)+++ -- |+ -- Default settings:+ --+ -- @+ -- SmtpSettings { smtpHost = \"localhost\"+ -- , smtpSender = \"localhost\"+ -- , smtpOverSSL = False+ -- , smtpSecure = True+ -- , smtpPort = 587+ -- , smtpAuth = Nothing+ -- , smtpDebug = False+ -- }+ -- @+ --+ defaultSmtpSettings :: SmtpSettings+ defaultSmtpSettings = SmtpSettings { smtpHost = "localhost"+ , smtpSender = "localhost"+ , smtpOverSSL = False+ , smtpSecure = True+ , smtpPort = 587+ , smtpAuth = Nothing+ , smtpDebug = False+ }+++ -- |+ -- Attempt to submit an email to be sent.+ --+ -- Can throw a "Hookup.ConnectionFailure" exception.+ --+ sendMail :: (MonadIO m)+ => SmtpSettings -- ^ Bunch of mandatory and/or useful settings.+ -> Text -- ^ Sender. This is usually the @Reply-To@.+ -> [Text] -- ^ Mail recipients in @To@ and @Cc@ + others.+ -> LBS.ByteString -- ^ Encoded email. Use @mime-mail@ package.+ -> m SmtpResult+ sendMail envSettings envSender envRecipients envBody = do+ liftIO do+ withOpenSSL do+ let params = settingsToParams envSettings+ in bracket (connect params) close \envConnection -> do+ runReaderT start Env {..}+++ settingsToParams :: SmtpSettings -> ConnectionParams+ settingsToParams SmtpSettings{..} =+ ConnectionParams { cpHost = T.unpack smtpHost+ , cpPort = smtpPort+ , cpSocks = Nothing+ , cpTls = toMaybe smtpOverSSL (tlsParams smtpSecure)+ , cpBind = Nothing+ }++ tlsParams :: Bool -> TlsParams+ tlsParams secure =+ defaultTlsParams { tpCipherSuite = "DEFAULT"+#if MIN_VERSION_hookup(0, 7, 0)+ , tpVerify = if secure then VerifyDefault else VerifyNone+#else+ , tpInsecure = not secure+#endif+ }++ -- State Machine -----------------------------------------------------------+++ type State = ReaderT Env IO SmtpResult+++ -- |+ -- Local environment for our state machine.+ --+ data Env+ = Env+ { envSettings :: SmtpSettings+ , envSender :: Text+ , envRecipients :: [Text]+ , envBody :: LBS.ByteString+ , envConnection :: Connection+ }+++ start :: State+ start = do+ withSuccess [] do+ starttls+++ starttls :: State+ starttls = do+ Env{envSettings = SmtpSettings{..}, envConnection} <- ask++ if smtpOverSSL+ then ehlo+ else do+ withResult [ "STARTTLS" ] \code rows -> do+ case (isOk code, smtpSecure) of+ (False, True) -> quit $ SmtpError code rows+ (False, False) -> ehlo+ (True, _) -> do+ let tls = tlsParams smtpSecure+ liftIO $ upgradeTls tls (T.unpack smtpHost) envConnection+ ehlo+++ ehlo :: State+ ehlo = do+ Env{envSettings = SmtpSettings{smtpSender}} <- ask+ withSuccess [ "EHLO ", T.encodeUtf8 smtpSender ] authenticate+++ authenticate :: State+ authenticate = do+ Env{envSettings = SmtpSettings{..}} <- ask++ case smtpAuth of+ Nothing -> mailFrom+ Just auth -> do+ withSuccess [ "AUTH PLAIN ", authString auth ] mailFrom+++ mailFrom :: State+ mailFrom = do+ Env{envSender, envRecipients} <- ask++ withSuccess [ "MAIL FROM:<"+ , T.encodeUtf8 envSender, ">"+ , if all isTextAscii (envSender : envRecipients)+ then ""+ else " SMTPUTF8"+ , " BODY=8BITMIME"+ ] rcptTo+++ rcptTo :: State+ rcptTo = do+ Env{envRecipients} <- ask+ addRecipients envRecipients+++ addRecipients :: [Text] -> State+ addRecipients [] = data_+ addRecipients (r:rs) = do+ withSuccess [ "RCPT TO:<", T.encodeUtf8 r, ">" ] do+ addRecipients rs+++ data_ :: State+ data_ = do+ Env{envBody, envConnection} <- ask++ withSuccess [ "DATA" ] do+ liftIO do+ sendLines envConnection (LBS.split 10 envBody)++ withSuccess [ "." ] do+ quit $ SmtpSuccess+++ quit :: SmtpResult -> State+ quit res = command [ "QUIT" ] >> return res+++ -- Utilities ---------------------------------------------------------------+++ sendLines :: Connection -> [LBS.ByteString] -> IO ()+ sendLines conn lines = do+ case lines of+ [] -> return ()+ [""] -> return ()+ (line:more) -> do+ if LBS.take 1 line == "."+ then send conn (LBS.toStrict $ "." <> line <> "\n")+ else send conn (LBS.toStrict $ line <> "\n")++ sendLines conn more+++ authString :: (Text, Text) -> BS.ByteString+ authString (login, password) =+ encodeBase64BS $ mconcat [ T.encodeUtf8 login, "\0"+ , T.encodeUtf8 login, "\0"+ , T.encodeUtf8 password, "\0"+ ]+++ command :: [BS.ByteString] -> ReaderT Env IO (Either String (Int, [BS.ByteString]))+ command parts = do+ Env{envConnection, envSettings = SmtpSettings{smtpDebug}} <- ask++ liftIO do+ when smtpDebug do+ BS.putStr $ mconcat [ "C: ", mconcat parts ]+ putStrLn ""++ unless ([] == parts) do+ send envConnection (mconcat parts <> "\r\n")++ res <- recvSmtp envConnection++ when smtpDebug do+ case res of+ Left reason -> do+ putStrLn $ "E: " <> reason++ Right (code, lines) -> do+ forM_ lines \line -> do+ putStr $ mconcat [ "S: ", show code, " " ]+ BS.putStr line+ putStrLn ""++ return res+++ withResult :: [BS.ByteString] -> (Int -> [BS.ByteString] -> State) -> State+ withResult parts body = do+ res <- command parts++ case res of+ Left reason -> return $ SmtpGibberish reason+ Right (code, rows) -> body code rows+++ withSuccess :: [BS.ByteString] -> State -> State+ withSuccess parts body = do+ withResult parts \code rows ->+ if isOk code+ then body+ else quit $ SmtpError code rows+++ isOk :: Int -> Bool+ isOk x = x >= 200 && x < 400+++ isTextAscii :: Text -> Bool+ isTextAscii = all isAscii . T.unpack+++ toMaybe :: Bool -> a -> Maybe a+ toMaybe yesno val = if yesno then Just val else Nothing+++-- vim:set ft=haskell sw=2 ts=2 et:
+ lib/Network/SMTP/Parser.hs view
@@ -0,0 +1,55 @@+-- |+-- Module : Network.SMTP.Parser+-- Copyright : Jan Hamal Dvořák+-- License : MIT+--+-- Maintainer : mordae@anilinux.org+-- Stability : unstable+-- Portability : non-portable (ghc)+--++module Network.SMTP.Parser+ ( recvSmtp+ )+where+ import Prelude hiding (lines)++ import Data.Attoparsec.ByteString.Char8+ import Hookup (Connection, recv)+ import Data.ByteString (ByteString)+++ recvSmtp :: Connection -> IO (Either String (Int, [ByteString]))+ recvSmtp conn = parseMore conn (parse smtpParser)+++ parseMore :: Connection+ -> (ByteString -> Result a)+ -> IO (Either String a)+ parseMore conn cont0 = do+ bstr <- recv conn 1000++ case cont0 bstr of+ Fail _ _ reason -> return $ Left reason+ Done _ result -> return $ Right result+ Partial cont1 -> parseMore conn cont1+++ smtpParser :: Parser (Int, [ByteString])+ smtpParser = do+ lines <- many' (lineSeptBy '-')+ final <- lineSeptBy ' '+ return (fst final, map snd lines <> [snd final])+++ lineSeptBy :: Char -> Parser (Int, ByteString)+ lineSeptBy sep = do+ code <- decimal+ _ <- char sep+ text <- takeTill \x -> x == '\r' || x == '\n'+ _ <- option '\r' (char '\r')+ _ <- char '\n'++ return (code, text)++-- vim:set ft=haskell sw=2 ts=2 et: