diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,7 @@ +# Changelog for hs-smtp-client + +## Unreleased changes + +## 0.1.0.0 + +Unleashed on the world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,24 @@ +Copyright 2019 Phlummox + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +2. 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. + +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 +HOLDER 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/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,57 @@ +# assumpta-core [![Hackage version](https://img.shields.io/hackage/v/assumpta-ci.svg?label=Hackage)](https://hackage.haskell.org/package/assumpta-ci) [![Linux Build Status](https://img.shields.io/travis/com/phlummox/assumpta-core.svg?label=Linux%20build)](https://travis-ci.com/phlummox/assumpta-core) [![phlummox](https://circleci.com/gh/phlummox/assumpta-core.svg?style=svg)](https://circleci.com/gh/phlummox/assumpta-core) + +A library for constructing SMTP clients, which provides the core functionality +for [assumpta](https://hackage.haskell.org/package/assumpta). +It provides a monad transformer and an mtl-style class for sending SMTP +commands (including `STARTTLS`) to a server and checking for expected +responses, over some abstract connection type. + +It does not provide a concrete implementation +which can actually be used to communicate over +a network - for that, see the +[assumpta](https://hackage.haskell.org/package/assumpta) package. + +## Installation + +`assumpta-core` can be installed in the standard way using `stack` +or `cabal` (e.g. `stack install assumpta-core`). + +## Usage + +See the [assumpta](https://hackage.haskell.org/package/assumpta) package +for examples of usage. + +Typically, you will want to: + +- write an instance of the `Connection` class in + [Network.Mail.Assumpta.Connection](http://hackage.haskell.org/package/assumpta/docs/Network-Mail-Assumpta-Connection.html), + providing a concrete implementation in terms of some networking + library. + ([assumpta](https://hackage.haskell.org/package/assumpta) contains + one based on + [connection](https://hackage.haskell.org/package/connection).) +- for convenience, write a type synonym for the `SmtpT` transformer, + specialized over your new `Connection` instance + (`MySmtpT = SmtpT MyConnection`). +- And that should be enough for you to start communicating + with a server. See the examples in + [assumpta](https://hackage.haskell.org/package/assumpta) for more + details. + +## FAQ + +- Q. Why the name 'Assumpta'? + + A. Dunno, I just like it as a name. It means "assumption" you know. + I find I make many of those when programming. + +## Acknowledgements + +Many thanks to +[Alexander Vieth](https://github.com/avieth) +(author of [smtp-mail-ng](http://hackage.haskell.org/package/smtp-mail-ng)), +and to [Jason Hickner](https://github.com/jhickner) and +[Matt Parsons](https://github.com/parsonsmatt) +(authors of [smtp-mail](http://hackage.haskell.org/package/smtp-mail)), +whose packages provided the original basis for the +assumpta-core code. 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/assumpta-core.cabal b/assumpta-core.cabal new file mode 100644 --- /dev/null +++ b/assumpta-core.cabal @@ -0,0 +1,144 @@ +cabal-version: 1.12 + + +name: assumpta-core +version: 0.1.0.0 +synopsis: Core functionality for an SMTP client +description: A library for constructing SMTP clients, which provides the + core functionality for + . It + provides a monad transformer and an mtl-style class for sending + SMTP commands (including `STARTTLS`) to a server and checking + for expected responses, over some abstract connection type. + . + It does not provide a concrete implementation + which can actually be used to communicate over + a network - for that, see the + + package. + . + For further details, please see the README on GitHub at + . +category: Network +homepage: https://github.com/phlummox/assumpta-core#readme +bug-reports: https://github.com/phlummox/assumpta-core/issues +author: phlummox +maintainer: phlummox2@gmail.com +copyright: 2020 phlummox +license: BSD2 +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + ChangeLog.md + +source-repository head + type: git + location: https://github.com/phlummox/assumpta-core + +-- This enables (or disables) the doctest test suite. Which +-- is set up to complain and fail if it is not run being run +-- with `stack`. +-- You can enable these tests from stack using +-- `--flag assumpta-core:test-doctests` +flag test-doctests + description: enable doctests + manual: True + default: False + +flag warnmore + description: Enable plenty of ghc warning flags + manual: True + default: True + +library + exposed-modules: + Network.Mail.Assumpta.Auth + Network.Mail.Assumpta.Instances + Network.Mail.Assumpta.Mock + Network.Mail.Assumpta.MonadSmtp + Network.Mail.Assumpta.Trans.Smtp + Network.Mail.Assumpta.ParseResponse + Network.Mail.Assumpta.Types + Network.Mail.Assumpta.Connection + hs-source-dirs: + src + build-depends: + base >=4.0 && <5 + , attoparsec + , base64-bytestring + , bytestring + , constraints + , cryptonite + , exceptions + , memory + , mtl + , text + , transformers + if flag(warnmore) + if impl(ghc >= 8.0.1) + ghc-options: + -Wall -Wcompat -Wincomplete-record-updates + -Wincomplete-uni-patterns -Wredundant-constraints + -Wno-name-shadowing -Wno-orphans -fwarn-tabs + else + ghc-options: + -Wall + default-language: Haskell2010 + +-- ** +-- - Only works with stack +-- - requires STACK_RESOLVER env var to be set +test-suite doctest-tests + type: exitcode-stdio-1.0 + main-is: doctest-tests.hs + hs-source-dirs: + test-other + ghc-options: -threaded -rtsopts -with-rtsopts=-N + if flag(warnmore) + if impl(ghc >= 8.0.1) + ghc-options: + -Wall -Wcompat -Wincomplete-record-updates + -Wincomplete-uni-patterns -Wredundant-constraints + -Wno-name-shadowing -Wno-orphans -fwarn-tabs + else + ghc-options: + -Wall + if !(flag(test-doctests)) + buildable: False + else + build-depends: + assumpta-core + , base >=4.0 && <5 + , Glob + , doctest + , shelly + , text + default-language: Haskell2010 + +test-suite hspec-tests + type: exitcode-stdio-1.0 + main-is: hspec-tests.hs + other-modules: + Network.Mail.Assumpta.MonadSmtpSpec + hs-source-dirs: + test-hspec + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + QuickCheck + , assumpta-core + , base >=4.0 && <5 + , bytestring + , hspec + , mtl + , text + if flag(warnmore) + if impl(ghc >= 8.0.1) + ghc-options: + -Wall -Wcompat -Wincomplete-record-updates + -Wincomplete-uni-patterns -Wredundant-constraints + -Wno-name-shadowing -Wno-orphans -fwarn-tabs + else + ghc-options: + -Wall + default-language: Haskell2010 diff --git a/src/Network/Mail/Assumpta/Auth.hs b/src/Network/Mail/Assumpta/Auth.hs new file mode 100644 --- /dev/null +++ b/src/Network/Mail/Assumpta/Auth.hs @@ -0,0 +1,110 @@ + +{-# LANGUAGE OverloadedStrings #-} + +{- | + +Authentication functions using 'MonadSmtp'. + +Aims to eventually implement +three widely-used SMTP authentication mechanisms: +Login, Plain, and Cram-MD5. + +Currently, Login is implemented. + +/TODO/: Add Cram-MD5, other auth methods. + +-} + +{- + +Refs: see RFCs, + https://networking.ringofsaturn.com/Protocols/smtpauth.php + +SMTP authentication standards, courtesy of Wikipedia +(https://en.wikipedia.org/wiki/SMTP_Authentication): + +- PLAIN (Uses Base64 encoding) +- LOGIN (Uses Base64 encoding) +- GSSAPI (Generic Security Services Application Program Interface) +- DIGEST-MD5 (Digest access authentication) +- MD5 +- CRAM-MD5 +- OAUTH10A (OAuth 1.0a HMAC-SHA1 tokens as defined in RFC 5849) +- OAUTHBEARER (OAuth 2.0 bearer tokens as defined in RFC 6750) + +TODO: use text-conversions-0.3.0? +Has a dedicated Base64 newtype. + +TODO: add tests for the auth funcs. + +-} + +module Network.Mail.Assumpta.Auth + ( + login + , UserName + , Password + ) + where + +import Crypto.Hash (MD5) +import Crypto.MAC.HMAC (hmac, HMAC) + +import Data.ByteArray.Encoding (convertToBase, Base(Base16)) +import qualified Data.ByteString as BS +import Data.ByteString (ByteString) +import qualified Data.ByteString.Base64 as B64 (encode) +import qualified Data.ByteString.Char8 as B8 + +import Network.Mail.Assumpta.MonadSmtp + +-- TODO - implement and SmtpAuth data type. + + +type UserName = ByteString +type Password = ByteString + +-- newtype Password = Password ByteString +--instance Show Password where +-- show _ = "****" + +-- | Perform LOGIN authentication using the specified username +-- and password. +-- +-- /TODO/: better reporting of errors when login fails. +-- Currently just throws an 'SMTPError' indicating that +-- @expectCode 235@ failed. +login :: MonadSmtp m => UserName -> Password -> m () +login username password = do + sendLine "AUTH LOGIN" + expectCode 334 + let username' = B64.encode username + password' = B64.encode password + sendLine username' + expectCode 334 + sendLine password' + expectCode 235 + +-- | Not implemented yet -- TODO +cramMd5 :: MonadSmtp m => UserName -> Password -> m () +cramMd5 _username _password = do + sendLine "XXXXX" + undefined + +-- cramMD5 function from smtp-mail by +-- Jason Hickner and Matt Parsons +cramMD5 :: String -> String -> String -> ByteString +cramMD5 challenge user pass = + B64.encode $ B8.unwords [user', convertToBase Base16 hmac'] + where + challenge' = toAscii challenge + user' = toAscii user + pass' = toAscii pass + + hmac' :: HMAC MD5 + hmac' = hmac challenge' pass' + + toAscii :: String -> ByteString + toAscii = BS.pack . map (toEnum.fromEnum) + + diff --git a/src/Network/Mail/Assumpta/Connection.hs b/src/Network/Mail/Assumpta/Connection.hs new file mode 100644 --- /dev/null +++ b/src/Network/Mail/Assumpta/Connection.hs @@ -0,0 +1,67 @@ + +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ConstraintKinds #-} + +{-# OPTIONS_HADDOCK show-extensions #-} + +{- | + +Class using type families to represent abstract connection types +that (in addition to the usual network operations) +can be upgraded from insecure to secure. + +Any instance must specify: + +* @'Params'@, the type of parameters that can be used to + open a connection. (This might be a just a tuple containing + just hostname and port, say, or might be some more complicated + structure.) + +* @'Cstrt'@, the constraints the methods require. For instance, + a 'Connection' using real network operations would likely + have 'MonadIO' as a constraint. + +* Implementations for 'open', 'close', 'send', 'recv' and 'upgrade'. + These are typically very thin wrappers around the operations + provided by a network library. +-} + +module Network.Mail.Assumpta.Connection + where + +import Control.Monad.Catch +import Data.ByteString ( ByteString ) +import Data.Constraint + +-- | Class for abstract connections over some +-- transport channel @c@. +class Connection c where + -- | Constraints an implementation must satisfy. + -- (e.g., 'MonadIO' for network-based connections.) + type Cstrt c :: (* -> *) -> Constraint + -- | Parameters used to create a connection -- + -- e.g. hostname, port, TLS settings, etc. + type Params c :: * + + open :: (Cstrt c) m => Params c -> m c -- ^ open a connection + close :: (Cstrt c) m => c -> m () -- ^ close a connection + send :: (Cstrt c) m => c -> ByteString -> m () -- ^ send a bytestring + recv :: (Cstrt c) m => c -> m ByteString -- ^ receive a bytestring + upgrade :: (Cstrt c) m => c -> m () -- ^ upgrade security + + +-- | @withConnection p a@ +-- +-- 'bracket' for 'Connection's. +-- Given some parameters @p@ for opening a connection: +-- open a connection, run some action @a@ with it, then +-- close. +withConnection :: + (MonadMask m, Cstrt c m, Connection c) => + Params c -> (c -> m b) -> m b +withConnection params = + bracket acquire release + where + acquire = open params + release = close + diff --git a/src/Network/Mail/Assumpta/Instances.hs b/src/Network/Mail/Assumpta/Instances.hs new file mode 100644 --- /dev/null +++ b/src/Network/Mail/Assumpta/Instances.hs @@ -0,0 +1,53 @@ + +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} + +{-# OPTIONS_HADDOCK show-extensions #-} + +{- | + +Instances for mtl classes which require UndecidableInstances. + +-} + +module Network.Mail.Assumpta.Instances + where + +import Control.Monad.Reader +import Control.Monad.State +import Control.Monad.Trans.Class (lift) +import Control.Monad.Writer + +import Network.Mail.Assumpta.Trans.Smtp + +instance MonadWriter w m => MonadWriter w (SmtpT conn m) where + writer = lift . writer + tell = lift . tell + listen (SmtpT m) = SmtpT $ listen m + pass (SmtpT m) = SmtpT $ pass m + +instance (MonadReader r m) => MonadReader r (SmtpT conn m) where + ask = liftSmtpT ask + local = mapSmtpT . local + +instance MonadState s m => MonadState s (SmtpT conn m) where + get = lift get + put = lift . put + state = lift . state + +-- TODO: MonadError. +-- +-- instance MonadError e m => MonadError e (SmtpT conn m) where +-- throwError = lift . throwError +-- +-- catchError :: SmtpT conn m a -> (e -> SmtpT conn m a) -> SmtpT conn m a +-- catchError = ... + +-- see eg WriterT: +-- -- | Lift a @catchE@ operation to the new monad. +-- liftCatch :: Catch e m (a,w) -> Catch e (WriterT w m) a +-- liftCatch catchE m h = +-- WriterT $ runWriterT m `catchE` \ e -> runWriterT (h e) + + diff --git a/src/Network/Mail/Assumpta/Mock.hs b/src/Network/Mail/Assumpta/Mock.hs new file mode 100644 --- /dev/null +++ b/src/Network/Mail/Assumpta/Mock.hs @@ -0,0 +1,61 @@ + +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +{- | + +Provides 'MockSmtp', a 'mock' instance of 'MonadSmtp', which simply +records (via use of a 'Writer') any bytes sent through it. +(Making it technically a \"spy", I think -- +see .) + +Plus a transformer version, 'MockSmtpT'. + +Sample use: + +>>> runMockSmtp (noop >> quit) +"NOOP\r\nQUIT\r\n" + +-} + +module Network.Mail.Assumpta.Mock + where + +import Control.Monad.Writer +import Data.Functor.Identity (Identity) +import Data.ByteString ( ByteString ) + +import Network.Mail.Assumpta.MonadSmtp + +-- | Concrete transformer for mock 'MonadSmtp' +-- monads. +newtype MockSmtpT m a = MockSmtpT { + runMockSmtpT :: WriterT ByteString m a + } + deriving (Functor, Applicative, Monad, MonadIO, MonadFix + , MonadWriter ByteString) + +-- | Lift into 'MockSmtpT'. +liftMockSmtpT :: Monad m => m a -> MockSmtpT m a +liftMockSmtpT = MockSmtpT . lift + +instance MonadTrans MockSmtpT where + lift = liftMockSmtpT + +-- | 'MockSmtp' specialized to 'Identity' +type MockSmtp = MockSmtpT Identity + +-- | In this mock monad, 'send' writes to the underlying 'Writer'; +-- 'expectCode' and 'tlsUpgrade' are no-ops; and 'getReply' +-- returns an empty list. (In breach of the req. that a +-- reply always contains at least one line.) +instance Monad m => MonadSmtp (MockSmtpT m) where + send = MockSmtpT . tell + getReply = return [] + expectCode = const $ pure () + tlsUpgrade = pure () + +-- | Run an 'MonadSmtp' computation using a mock, +-- and return the 'ByteString' content written. +runMockSmtp :: MockSmtp a -> ByteString +runMockSmtp a = execWriter $ runMockSmtpT a + diff --git a/src/Network/Mail/Assumpta/MonadSmtp.hs b/src/Network/Mail/Assumpta/MonadSmtp.hs new file mode 100644 --- /dev/null +++ b/src/Network/Mail/Assumpta/MonadSmtp.hs @@ -0,0 +1,438 @@ + + +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} + +{- | + +A monad for sending SMTP commands and checking +for expected responses. + +== #permissiblecharacters# Permissible characters + +This module accepts 'ByteString's as parameters, but it is +the responsibility of the caller to ensure that the bytestrings +meet the requirements of the appropriate RFC; we do not +validate them. + +In general, +commands and replies must be composed of composed of characters from +the ASCII character set (with the possible exception of content +supplied after a \'DATA' command); see sec 2.4 of the RFC. +That is, they must be '7-bit clean'. + +RFC 5321 notes that although various SMTP extensions (such as "8BITMIME", +) may relax this restriction for +the content body, content header fields are always encoded using US-ASCII. +See also , "SMTP Service Extensions", +for details of suppling DATA in non-ASCII format. + +Note also that unless increased using some SMTP extension, +RFC 5321 imposes maximum sizes on the length of (\-terminated) +lines sent to the server (see sec. 4.5.3, "Sizes and Timeouts"). +Again, we don't enforce these requirements, it's up to the caller +to check that they're satisfied. + +== Constructing email messages + +This package does not provide facilities for constructing email +messages, but only sending them via SMTP. +See the + +package to construct and properly render email messages. + +-} + +module Network.Mail.Assumpta.MonadSmtp + ( + -- * SMTP monad + MonadSmtp(..) + -- * SMTP commands + , helo + , ehlo + , mailFrom + , rcptTo + , data_ + , noop + , quit + , rset + , startTLS + , expn + , vrfy + , help + -- * Server responses + , expect + , expectGreeting + -- * Low-level MonadSmtp operations + , sendLine + , command + -- * Send an email message + , sendRawMail + -- * Types + , SmtpCommand(..) + , Reply + , ReplyLine(..) + , ReplyCode + , SmtpError(..) + , ByteString + -- * Utility functions + , crlf + ) + where + +import Control.Monad.Except +import Control.Monad.Reader +import Control.Monad.Trans.Maybe as Maybe + +-- for transformer instances +-- __TODO__: finish off doing these +import Control.Monad.Trans.Identity +import Control.Monad.Trans.RWS.Lazy as LazyRWS +import Control.Monad.Trans.RWS.Strict as StrictRWS +import Control.Monad.Trans.State.Lazy as LazyState +import Control.Monad.Trans.State.Strict as StrictState +import Control.Monad.Trans.Writer.Lazy as LazyWriter +import Control.Monad.Trans.Writer.Strict as StrictWriter + +import qualified Data.ByteString.Char8 as BSC +import Data.ByteString ( ByteString ) +import Data.Monoid -- needed for early versions of Base +import Data.String + +import Network.Mail.Assumpta.Types as Types + +{-# ANN module ("HLint: ignore Eta reduce" :: String) #-} + +-- | Monad for sending SMTP commands and checking +-- for expected responses. +-- +class Monad m => MonadSmtp m where + -- | Send some bytes. + send :: ByteString -> m () + + -- | Attempt to read a response from the server, + -- parsing it as a 'Reply'. + getReply :: m Reply + + -- | Attempt to read and parse a server response, indicating that we + -- expect it to be the given 'ReplyCode'. + -- + -- In some 'MonadSmtp' instances, failure of the expectation will result + -- in an exception being thrown. + -- If you are writing an instance of @MonadSmtp m@ + -- where @MonadError SmtpError m@ holds, we can supply a default + -- implementation for you. + expectCode :: ReplyCode -> m () + + default expectCode :: (MonadError SmtpError m) => ReplyCode -> m () + expectCode expectedCode = void $ + expect (== expectedCode) (show expectedCode) + + -- | Upgrade from plain STMP to SMTPS using default TLS + -- settings + tlsUpgrade :: m () + -- TODO: might want to throw an error if someone tries to + -- call tlsUpgrade on a channel that is already secure. + +instance MonadSmtp m => MonadSmtp (IdentityT m) where + send = lift . send + getReply = lift getReply + tlsUpgrade = lift tlsUpgrade + expectCode = lift . expectCode + +instance MonadSmtp m => MonadSmtp (MaybeT m) where + send = lift . send + getReply = lift getReply + tlsUpgrade = lift tlsUpgrade + expectCode = lift . expectCode + +instance MonadSmtp m => MonadSmtp (ReaderT r m) where + send = lift . send + getReply = lift getReply + tlsUpgrade = lift tlsUpgrade + expectCode = lift . expectCode + +instance (Monoid w, MonadSmtp m) => MonadSmtp (LazyRWS.RWST r w s m) where + send = lift . send + getReply = lift getReply + tlsUpgrade = lift tlsUpgrade + expectCode = lift . expectCode + +instance (Monoid w, MonadSmtp m) => MonadSmtp (StrictRWS.RWST r w s m) where + send = lift . send + getReply = lift getReply + tlsUpgrade = lift tlsUpgrade + expectCode = lift . expectCode + +instance (MonadSmtp m) => MonadSmtp (LazyState.StateT s m) where + send = lift . send + getReply = lift getReply + tlsUpgrade = lift tlsUpgrade + expectCode = lift . expectCode + +instance (MonadSmtp m) => MonadSmtp (StrictState.StateT s m) where + send = lift . send + getReply = lift getReply + tlsUpgrade = lift tlsUpgrade + expectCode = lift . expectCode + +instance (Monoid w, MonadSmtp m) => MonadSmtp (StrictWriter.WriterT w m) where + send = lift . send + getReply = lift getReply + tlsUpgrade = lift tlsUpgrade + expectCode = lift . expectCode + +instance (Monoid w, MonadSmtp m) => MonadSmtp (LazyWriter.WriterT w m) where + send = lift . send + getReply = lift getReply + tlsUpgrade = lift tlsUpgrade + expectCode = lift . expectCode + +instance (MonadSmtp m) => MonadSmtp (ExceptT e m) where + send = lift . send + getReply = lift getReply + tlsUpgrade = lift tlsUpgrade + expectCode = lift . expectCode + +--instance MonadError e m => MonadError e (ReaderT r m) where +-- throwError = lift . throwError +-- catchError = Reader.liftCatch catchError + +-- __TODO__: Monad {Reader, Writer, State} + +-- | @expect pred expectDescrip@ +-- +-- Fetch a reply, and validate that its reply code +-- meets predicate @pred@; on failure, an +-- 'UnexpectedResponse' is thrown into the 'MonadError' +-- monad. (So a caller can easily convert it to a +-- 'Maybe' or 'Either' or any other instance.) +-- +-- Takes a human-readable +-- description of what was expected, which is +-- included in the exception. +-- +-- Useful for implementing 'expectCode'. +expect :: + (MonadSmtp m, MonadError SmtpError m) => + (ReplyCode -> Bool) -> String -> m Reply +expect pred expectDescrip = + getReply >>= meetsPred + where + meetsPred r = + if pred $ replyCode $ head r + then return r + else throwError $ UnexpectedResponse expectDescrip r + +-- | Send some bytes, with a 'crlf' inserted at the end. +sendLine :: MonadSmtp m => ByteString -> m () +sendLine bs = send $ bs <> crlf + +-- | Send a command, without waiting for the reply. +command :: MonadSmtp m => SmtpCommand -> m () +command cmd = + sendLine (toByteString cmd) + +unaryCommand :: MonadSmtp m => + (a -> SmtpCommand) -> a -> m () +unaryCommand f = + sendLine . toByteString . f + +-- | Expect code 220, a "Service ready" message (or +-- "greeting"). +-- +-- Every client session should /start/ by waiting +-- for the server to send a "Service ready" message. +expectGreeting :: MonadSmtp m => m () +expectGreeting = + expectCode 220 + + +-- | Convenience func. +-- +-- @helo myhostname@ will send '@HELO myhostname@', expect 250. +helo :: MonadSmtp m => ByteString -> m () +helo bs = + unaryCommand HELO bs >> + expectCode 250 + +-- | Convenience func. +-- +-- @ehlo myhostname@ will send '@EHLO myhostname@', expect 250. +ehlo :: MonadSmtp m => ByteString -> m () +ehlo clientHostName = + unaryCommand EHLO clientHostName >> + expectCode 250 + +-- | Convenience func. +-- +-- @mailFrom sender@ will send '@MAIL FROM:\@', expect 250. +mailFrom :: MonadSmtp m => ByteString -> m () +mailFrom sender = + unaryCommand MAIL sender >> + expectCode 250 + +-- | Convenience func. +-- +-- @rcptTo recipient@ will send '@RCPT TO:\@', expect 250. +rcptTo :: MonadSmtp m => ByteString -> m () +rcptTo recipient = + unaryCommand RCPT recipient >> + expectCode 250 + + +-- | convenience func. Send a \'DATA' command, expect 354, +-- send bytestring content (which should be terminated by +-- the sequence \), +-- expect 354. +-- +-- See for +-- details of the 'DATA' command. +-- +-- Prerequisites: +-- +-- * "The mail data may contain any of the 128 ASCII character codes, +-- although experience has indicated that use of control characters +-- other than SP, HT, CR, and LF may cause problems and SHOULD be +-- avoided when possible." [RFC 5321, p. 35] +-- +-- We don't check that the bytestring being sent is indeed 7-bit +-- clean; that's up to the caller. +-- +-- * Any periods at the start of a line SHOULD be escaped. +-- (See RFC 5321, p. 61, \"Transparency".) It is up to the caller +-- to ensure this has been done. +-- +-- * The content passed should end in \'@\@' (i.e., +-- a @\@, then a full stop on a line by itself, +-- then @\@. We don't check that this is the case. +data_ :: MonadSmtp m => ByteString -> m () +data_ bs = do + command DATA + expectCode 354 + send bs + expectCode 250 + +-- | Convenience func. Send NOOP, +-- expect 250. +-- +-- See +-- , +-- p. 39, sec 4.1.1.9 ("NOOP (NOOP)") +noop :: MonadSmtp m => m () +noop = do + command NOOP + expectCode 250 + +-- | Convenience func. Send QUIT, +-- expect 221. +-- +-- See , +-- p. 39, sec 4.1.1.10 ("QUIT (QUIT)"). +quit :: MonadSmtp m => m () +quit = do + command QUIT + expectCode 221 + + +-- | Convenience func. Send RSET (used to abort +-- transaction), expect 250. +-- +-- See , +-- p. 37, sec 4.1.1.5 ("RESET (RSET)"). +rset :: MonadSmtp m => m () +rset = do + command RSET + expectCode 250 + +-- | Try to get TLS going on an SMTP connection. +-- +-- After this, you should send an EHLO. +-- +-- RFC reference: __???__ +startTLS :: MonadSmtp m => m () +startTLS = do + command STARTTLS + expectCode 220 + tlsUpgrade + +-- | Convenience func. +-- +-- @help myhostname@ will send \'@HELP myhostname@' and +-- attempt to parse a 'Reply'. +help :: MonadSmtp m => Maybe ByteString -> m Reply +help bs = + unaryCommand HELP bs >> + getReply + +-- | Convenience func. +-- +-- @expn recipient@ will send '@EXPN recipient@' and +-- attempt to parse a 'Reply'. The 'EXPN' command +-- asks the server to verify that the recipient is +-- a mailing list, and return the members of the +-- list. Many servers restrict access to this +-- command. +expn :: MonadSmtp m => ByteString -> m Reply +expn recipient = + unaryCommand EXPN recipient >> + getReply + +-- | Convenience func. +-- +-- @vrfy recipient@ will send '@VRFY recipient@' and +-- attempt to parse a 'Reply'. The 'VRFY' command +-- asks the server to confirm that the argument +-- identifies a user or mailbox. +-- Many servers restrict access to this +-- command +vrfy :: MonadSmtp m => ByteString -> m Reply +vrfy recipient = + unaryCommand VRFY recipient >> + getReply + +-- | @sendRawMail sender recipients message@ +-- +-- convenience func. Expects a raw 'ByteString' +-- that can be sent after a data command. +-- +-- sends MAIL FROM, RCPT TO commands as appropriate, +-- expecting 250 in each case. +-- Then sends data, likewise expecting 250. +-- +-- We don't alter the content of @message@, expect insofar +-- as specified by RFC, p. 36, namely: +-- If the body content passed does not end in @\@, a +-- client must either reject the message as invalid or +-- add @\@ to the end; +-- we do the latter. (We are not permitted to alter the content +-- in any other case.) +-- +-- We then append the \'@\<.CRLF>@' used to terminate the data +-- (this is not considered part of the message). +-- +-- Other than that, the same requirements apply as for +-- the 'data_' function. +sendRawMail :: + (MonadSmtp m, Foldable t) => + ByteString -> t ByteString -> ByteString -> m () +sendRawMail sender recipients message = do + mailFrom sender + expectCode 250 + mapM_ rcptTo recipients + + let messageEnd = + if crlf `BSC.isSuffixOf` message + then "." <> crlf + else crlf <> "." <> crlf + data_ $ message <> messageEnd + + +-- | A @"\\r\\n"@ sequence, indicated @\@ in the RFC, +-- used to terminate all lines sent. +crlf :: Data.String.IsString p => p +crlf = "\r\n" + + + diff --git a/src/Network/Mail/Assumpta/ParseResponse.hs b/src/Network/Mail/Assumpta/ParseResponse.hs new file mode 100644 --- /dev/null +++ b/src/Network/Mail/Assumpta/ParseResponse.hs @@ -0,0 +1,227 @@ + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} + +{- | + +Parse server replies. + +The general format of replies is described in +, at p. 49: + +@ + The format for multiline replies requires that every line, + except the last, begin with the reply code, followed + immediately by a hyphen, "-" (also known as minus), followed by + text. The last line will begin with the reply code, followed + immediately by \, optionally some text, and \. + + For example: + 123-First line + 123-Second line + 123-234 text beginning with numbers + 123 The last line +@ + +On p. 49, sec 4.2.2, "Reply Codes by Function Groups", the RFC lists the +various server responses that can be made. +(Also Wikipedia has a more pleasantly formatted version of the list at +.) +-} + +module Network.Mail.Assumpta.ParseResponse + ( + -- * Fetching replies + + -- | 'getReply' is intended to be the main function + -- used by other modules - it allows fetching and parsing replies + -- from a server. The other functions are lower-level utility functions, and + -- might be useful if you want to customize parsing. + + getReply + + -- * Low-level functions and types + , Parser + , textstring + , code + , reply + , getReply_ + , parseFrom + ) + + where + +import Control.Monad.Except +import qualified Data.Attoparsec.ByteString.Char8 as Att +import Data.Attoparsec.ByteString.Char8 ( decimal + , takeWhile1, string + , char, option + , space, many' + , parseWith, eitherResult + , () ) +import qualified Data.ByteString as BS +import Data.ByteString ( ByteString) +import Data.Functor +import qualified Data.List as L +import Data.Monoid -- needed for early versions of Base + +import Network.Mail.Assumpta.Types + +#if MIN_VERSION_mtl(2,2,2) +#else +liftEither :: MonadError e m => Either e a -> m a +liftEither = either throwError return +#endif + +-- | parser type. +type Parser = Att.Parser + + +-- | +-- A string of length at least 1, which may contain printable US ASCII, +-- characters, space characters, and horizontal tabs. +-- +-- See , p. 47, "textstring". +-- +-- The spec in the RFC is +-- +-- @ +-- textstring = 1*(%d09 / %d32-126) ; HT, SP, Printable US-ASCII +-- @ +-- +-- >>> :set -XOverloadedStrings +-- >>> Att.parseOnly (textstring <* Att.endOfInput) "~" -- ASCII 126 +-- Right "~" +-- >>> Att.parseOnly (textstring <* Att.endOfInput) "\x7f" -- ASCII 127 +-- Left "printable ASCII text: Failed reading: takeWhile1" +textstring :: Parser ByteString +textstring = (takeWhile1 is_printable) "printable ASCII text" + where + -- 9 is horizontal tab, and [32, 126] is all printable US ASCII. + is_printable c' = let c = fromEnum c' in c == 9 || (c >= 32 && c <= 126) + -- textstring function courtesy of + -- Alexander Vieth, smtp-mail-ng + +-- | The @\@ sequence. +-- +-- >>> :set -XOverloadedStrings +-- >>> Att.parseOnly (crlf <* Att.endOfInput) "\r\n" +-- Right () +-- >>> Att.parseOnly (crlf <* Att.endOfInput) "\r\n." +-- Left "endOfInput" +crlf :: Parser () +crlf = string "\r\n" $> () + +-- | Parser for a reply code. +-- +-- The RFC states that an SMTP server SHOULD only send the codes +-- listed in the spec, but we don't validate that here; +-- we accept any sequence of decimal digits, higher-level functions can +-- further validate it if desired. +-- +-- >>> :set -XOverloadedStrings +-- >>> Att.parseOnly (code <* Att.endOfInput) "42" +-- Right 42 +-- >>> Att.parseOnly (code <* Att.endOfInput) "042" +-- Right 42 +code :: Parser ReplyCode +code = decimal + +-- | One or more server reply lines, terminating with a +-- last line. The parser does not check that they all have the +-- same reply code. +reply :: Parser Reply +reply = (++) <$> many' continue + <*> (pure <$> lastLine) + +-- | Last line of a (potentially multi-line) reply. +-- +-- Code and , possibly a text string. +-- +-- >>> :set -XOverloadedStrings +-- >>> let bs = "42 Answering your questions\r\n" +-- >>> Att.parseOnly (lastLine <* Att.endOfInput) bs +-- Right (ReplyLine {replyCode = 42, replyText = "Answering your questions"}) +lastLine :: Parser ReplyLine +lastLine = ReplyLine <$> code <* space + <*> option "" textstring <* crlf + +-- | Continuation line of a multiline reply. +-- +-- Code and '-' char, possibly a text string. +-- +-- >>> :set -XOverloadedStrings +-- >>> let bs = "42-Answering your questions\r\n" +-- >>> Att.parseOnly (continue <* Att.endOfInput) bs +-- Right (ReplyLine {replyCode = 42, replyText = "Answering your questions"}) +continue :: Parser ReplyLine +continue = ReplyLine <$> code <* char '-' + <*> option "" textstring <* crlf + +-- | @parseFrom x pull@ +-- +-- Given some action \'pull' which can be called to +-- supply the parser with more input, parse thing 'x' +-- and return a result. +parseFrom :: + Monad m => Parser r -> m ByteString -> m (Either String r) +parseFrom x pull = + eitherResult <$> parseWith pull x BS.empty + +-- | @getReply_ pull@ +-- +-- Given some action \'pull' which can be called to +-- supply the parser with more input, attempt to +-- fetch input and parse it as a superficially +-- well-formed 'Reply' (multiple lines ending in a terminating +-- line). +-- We don't check that all reply lines have the +-- same reply code. +getReply_ :: Monad m => m ByteString -> m (Either String Reply) +getReply_ pull = + eitherResult <$> parseWith pull reply BS.empty + +allSame :: Eq a => [a] -> Bool +allSame [] = True +allSame (x:xs) = all (== x) xs + +toParseError :: Either String b -> Either SmtpError b +toParseError = either (Left . ParseError) Right + +-- | @getReply pull@ +-- +-- Given some action \'pull' which can be called to +-- supply the parser with more input, attempt to fetch +-- content from the server and parse it as a 'Reply'. +-- On failure, 'ParseError' will be thrown, with +-- a message explaining the failure. +-- +-- A 'ParseError' will also be thrown if the response +-- looks superficially like a reply, but has multiple +-- reply codes for different lines. (In other words, +-- a successful return value means the reply has at +-- least one line, and all lines have the same reply +-- code.) +-- +-- The result returned is in the 'MonadError' monad, +-- so can be specialised by the caller to a 'Maybe', +-- 'Either', or some other 'MonadError' instance as desired. +getReply :: MonadError SmtpError m => m ByteString -> m Reply +getReply f = + wellFormed =<< liftEither =<< toParseError <$> getReply_ f + + +-- | Check if reply is well-formed (has same reply code +-- for each line) else throw a 'ParseError'. +wellFormed :: + MonadError SmtpError m => Reply -> m Reply +wellFormed replyLines = + let codes = map replyCode replyLines + mesg = "Malformed reply contained multiple reply codes: " + <> L.intercalate ", " (map show codes) + in if allSame codes + then return replyLines + else throwError (ParseError mesg) + + diff --git a/src/Network/Mail/Assumpta/Trans/Smtp.hs b/src/Network/Mail/Assumpta/Trans/Smtp.hs new file mode 100644 --- /dev/null +++ b/src/Network/Mail/Assumpta/Trans/Smtp.hs @@ -0,0 +1,139 @@ + +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +#if __GLASGOW_HASKELL__ >= 801 +{-# OPTIONS_GHC -Wno-redundant-constraints #-} +#endif + +{-# OPTIONS_HADDOCK show-extensions #-} + +{- | + +This module provides a template for creating implementations +of 'MonadSmtp' over some abstract connection type. + +Operations on a connection can throw IO- and network-based errors, +and we don't handle those in any particular way +ourselves. However, we throw 'SmtpError's if server responses +are unparseable or unexpected. + +-} + +module Network.Mail.Assumpta.Trans.Smtp + ( + -- * Abstract connections + module Conn + + -- * SMTP operations + -- + -- A monad transformer, 'SmtpT', which provides the ability to + -- send SMTP commands and parse replies, plus operations + -- on the transformer. + , SmtpT(..) + , liftSmtpT + , mapSmtpT + , MonadSmtp + -- ** run SmptT actions + , runSmtpEither + , runSmtp + , withSmtpConnection + -- * Utility functions + , rethrow + ) + where + +import Control.Monad.Catch (bracket, MonadMask) +import Control.Monad.Except +import Control.Monad.Reader + +import Network.Mail.Assumpta.Connection as Conn +import Network.Mail.Assumpta.Types +import Network.Mail.Assumpta.MonadSmtp as MonadSmtp +import Network.Mail.Assumpta.ParseResponse as P (getReply) + +{-# ANN module ("HLint: ignore Eta reduce" :: String) #-} + +-- | Monad transformer that adds the ability to send SMTP +-- commands and receive server replies over some abstract +-- communications channel, \'conn'. +newtype SmtpT conn m a = SmtpT { + unSmtpT :: ReaderT conn (ExceptT SmtpError m) a + } + deriving (Functor, Applicative, Monad, MonadIO, MonadFix + , MonadError SmtpError, MonadReader conn + ) + +-- | An instance of 'MonadSmtp' communicating over +-- some 'Connection' type, @conn@. +instance (Connection conn, cstr ~ Cstrt conn, Monad m, cstr (SmtpT conn m)) + => MonadSmtp.MonadSmtp (SmtpT conn m) + where + send bs = ask >>= (`Conn.send` bs) + getReply = asks recv >>= P.getReply + tlsUpgrade = ask >>= upgrade + +-- | 'lift', specialised to the 'SmtpT' transformer. +liftSmtpT :: Monad m => m a -> SmtpT conn m a +liftSmtpT = SmtpT . lift . lift + +instance MonadTrans (SmtpT conn) where + lift = liftSmtpT + +-- | convert an ExceptT into a MonadError +rethrow :: MonadError e m => ExceptT e m b -> m b +rethrow = (>>= either throwError return) . runExceptT + + +-- | Lifted 'mapExceptT'. +mapSmtpT :: + (m1 (Either SmtpError a1) -> m2 (Either SmtpError a2)) + -> SmtpT conn m1 a1 -> SmtpT conn m2 a2 +mapSmtpT f (SmtpT x) = SmtpT (mapBoth f x) + where + mapBoth = mapReaderT . mapExceptT + +-- | @runSmtpEither c a@ +-- +-- Run an 'SmtpT' computation @a@ using some connection @c@, +-- and return the result as an 'Either'. +runSmtpEither :: conn -> SmtpT conn m a -> m (Either SmtpError a) +runSmtpEither c = runExceptT . flip runReaderT c . unSmtpT + +-- | @runSmtp c a@ +-- +-- 'runSmtpEither' generalized to 'MonadError', so +-- a caller can +-- use 'Maybe' or or 'MonadError' instances as they choose. +runSmtp :: MonadError SmtpError m => conn -> SmtpT conn m b -> m b +runSmtp c = + rethrow . flip runReaderT c . unSmtpT + +-- | 'withConnection', specialized to only run +-- 'MonadSmtp.MonadSmtp' actions. +withSmtpConnection + :: (Cstrt c m, MonadMask m, Connection c, MonadSmtp.MonadSmtp m) => + Params c -> (c -> m b) -> m b +withSmtpConnection = withConnection + +-- | @withSmtpRunner params r a@ +-- +-- A variant on 'withSmtpConnection', +-- where the caller supplies a \'runner' @r@, which can +-- run 'MonadSmtp.MonadSmtp' actions @a@ and return a result +-- in the current monad. +withSmtpRunner :: + (MonadMask m, Cstrt conn m, Connection conn) => + Params conn -> (conn -> (forall n . MonadSmtp.MonadSmtp n => n b) -> m b) -> (forall n . MonadSmtp.MonadSmtp n => n b) -> m b +withSmtpRunner params f a = + bracket acquire release (`f` a) + where + acquire = open params + release = close + diff --git a/src/Network/Mail/Assumpta/Types.hs b/src/Network/Mail/Assumpta/Types.hs new file mode 100644 --- /dev/null +++ b/src/Network/Mail/Assumpta/Types.hs @@ -0,0 +1,143 @@ + +{-# LANGUAGE OverloadedStrings #-} + +{- | + +Types for use with SMTP. + +== Notes + +Some notes on the underlying bits of the SMTP +protocol they model (see + for +more details): + +* The protocol consists of /commands/ and /replies/. + +* /Replies/ can be single-line or multiline. + Single lines start with @\ \@; + for multiple lines, every line except the last + starts with @\ \'-'@, and the last + is a single line. + + The @\@ or @\'-'@ can be followed by optional text. + Our 'ReplyLine' and 'Reply' store the code and the optional + text (or an empty string if there was none), but + not the @\@ or @\'-'@ separator. + +* A reply is a list of /one or more/ of these reply + lines; but we just represent it as a list; it's an invariant + that such a list should never be empty (and the + parser promises never to return an empty list). + +-} + +{- +TODO: func converting codes into Eng. lang human +readable textual descriptions would be nice. + +Consideration: It would be *nice*, when a parse fails, to +give knowledgeable callers the *exact*, pre-parse, +content that we received. But that sounds annoyingly fiddly. +And might never be used. + +-} + +module Network.Mail.Assumpta.Types + where + +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as BS +import Data.Monoid -- needed for early Base + +-- | Reply code from a server +type ReplyCode = Int + +-- | Response from a serve +type Reply = [ReplyLine] + +-- | One line of a reply from a server, consisting of a 'ReplyCode' and US-ASCII message. +data ReplyLine = ReplyLine { + replyCode :: !ReplyCode + , replyText :: !ByteString + } + deriving (Show) + +-- | SMTP commands. This type does not +-- include the \'@AUTH@' command, which +-- has a flexible form. +data SmtpCommand + = HELO ByteString + | EHLO ByteString + | MAIL ByteString + | RCPT ByteString + | DATA + | EXPN ByteString + | VRFY ByteString + | HELP (Maybe ByteString) + | NOOP + | RSET + | QUIT + | STARTTLS + deriving (Show, Eq) + +-- | Errors that can occur during SMTP operations. +-- +-- These don't include connectivity and other IO errors +-- which might occur in the underlying transport +-- mechanism; +-- those should be handled elsewhere (if necessary). +-- +-- The possible errors are that either (a) we couldn't +-- parse the server's response at all, or (b) we could, +-- but it wasn't what we expected. +data SmtpError + + -- | We received a response contrary + -- to what we expected. The first + -- field is a description of what we expected, + -- the second of what we got. + = UnexpectedResponse { + expected :: String + , received :: Reply + } + + -- | We couldn't parse the server's + -- response; the parser gave the + -- error message contained in the 'ParseError'. + | ParseError String + deriving Show + +-- | Dump an SMTP command to a bytestring, suitable for transmission to a +-- server. No CRLF is appended. +-- +-- For commands like '@MAIL FROM:\@': +-- this adds in the 'FROM:<' etc +-- +-- >>> :set -XOverloadedStrings +-- >>> toByteString $ HELO "my-computer.org" +-- "HELO my-computer.org" +-- >>> toByteString $ MAIL "some-sender@my-org.com" +-- "MAIL FROM:" +-- >>> toByteString $ RCPT "delighted-recipient@dunder-mifflin.com" +-- "RCPT TO:" +toByteString :: SmtpCommand -> ByteString +toByteString command = case command of + HELO bs -> unwords ["HELO", bs] + EHLO bs -> unwords ["EHLO", bs] + MAIL bs -> "MAIL FROM:<" <> bs <> ">" + RCPT bs -> "RCPT TO:<" <> bs <> ">" + EXPN bs -> unwords ["EXPN", bs] + VRFY bs -> unwords ["VRFY", bs] + HELP Nothing -> "HELP" + HELP (Just bs) -> unwords ["HELP", bs] + DATA -> "DATA" + NOOP -> "NOOP" + RSET -> "RSET" + QUIT -> "QUIT" + STARTTLS -> "STARTTLS" + where + unwords = BS.unwords + + + diff --git a/test-hspec/Network/Mail/Assumpta/MonadSmtpSpec.hs b/test-hspec/Network/Mail/Assumpta/MonadSmtpSpec.hs new file mode 100644 --- /dev/null +++ b/test-hspec/Network/Mail/Assumpta/MonadSmtpSpec.hs @@ -0,0 +1,153 @@ + +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} + +module Network.Mail.Assumpta.MonadSmtpSpec + (main, spec) + where + +import Test.Hspec +import Test.QuickCheck + +import Data.String + +import Network.Mail.Assumpta.MonadSmtp as S +import Network.Mail.Assumpta.Mock as Mock + +import Control.Monad.Writer +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BSC +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as BS (intercalate) + + +sampleMesgLines :: IsString s => [s] +sampleMesgLines = [ + "Date: Tue, 21 Jan 2020 02:28:37 +0800" + , "To: Someone" + , "From: Someone else" + , "Subject: test message" + , "" + , "This is a test mailing" + ] + +-- | given an intercalate function, produce a message +-- from sampleMesgLines which does NOT end in a crlf. +joinMesg :: (IsString s) => (s -> [s] -> s) -> s +joinMesg f = + f crlf sampleMesgLines + +-- | sequences of commands in the SMTP monad, +-- and the bytestrings we expect to see sent by them. +-- We *don't* validate that inputs are sensible -- +-- assumpta-core trusts the user to only pass +-- data that is valid according to the relevant RFCs. +-- +-- tuple is: (description, test seq, expected response) +testSequences :: [(String, MockSmtp (), BS.ByteString)] +testSequences = [ + ( "trivial session" + , ehlo "myhost.mydomain" >> + quit + , "EHLO myhost.mydomain\r\nQUIT\r\n" + ) + + , ( "expecting code sends nothing" + , expectCode 250 + , "" + ) + + -- for message content not ending in CRLF: we must add a CRLF + -- (plus the terminating ".\r\n"). + , let bs = joinMesg BS.intercalate + in + ( "short message not ending in CRLF, sent via sendRawMail" + , + sendRawMail "sender@s.com" ["recipient@r.com"] bs + , "MAIL FROM:\r\nRCPT TO:\r\nDATA\r\n" + <> bs <> "\r\n.\r\n" + ) + + -- for message content that DOES end in CRLF, we can only + -- add the terminating ".\r\n". + , let bs = joinMesg BS.intercalate <> crlf + in + ( "short message ending in CRLF, sent via sendRawMail" + , + sendRawMail "sender@s.com" ["recipient@r.com"] bs + , "MAIL FROM:\r\nRCPT TO:\r\nDATA\r\n" + <> bs <> ".\r\n" + ) + + -- ** no-param commands + , nullaryCommand noop "NOOP" + , nullaryCommand quit "QUIT" + , nullaryCommand rset "RSET" + , nullaryCommand startTLS "STARTTLS" + ] + +-- | e.g. @nullaryCommand quit "QUIT"@ +-- specifies that the result of executing the command-sequence +-- quit +-- is just that we send the string "QUIT", terminated with crlf. +nullaryCommand :: MockSmtp () -> (forall s . IsString s => s) -> + (String, MockSmtp (), ByteString) +nullaryCommand a str = + (str <> " command", a, str <> (crlf :: ByteString)) + +-- | check that a sequence of MockSmtp commands sends the +-- expected ByteString. +evalTestSeq :: (String, MockSmtp (), BS.ByteString) -> Expectation +evalTestSeq (_, a, expectBS) = + runMockSmtp a `shouldBe` expectBS + + +dataSpec :: SpecWith () +dataSpec = + describe "data_" $ + it "should pass on its parameter unaltered" $ property $ \xs -> + let bs = BSC.pack xs + output = runMockSmtp $ data_ bs + expected_output = "DATA" <> crlf <> bs + in expected_output == output + +sendRawMailSpec :: SpecWith () +sendRawMailSpec = + describe "sendRawMail" $ do + context "when passed content that does NOT end in crlf" $ + it "will add a CRLF (and the '.CRLF' terminator)" $ property $ \xs -> + let bs = BSC.pack $ xs <> "|" -- our input doesn't end in crlf + output = runMockSmtp $ + sendRawMail "sender@s.com" ["recipient@r.com"] bs + expected_output = + "MAIL FROM:\r\n" + <> "RCPT TO:\r\n" + <> "DATA\r\n" + <> bs <> "\r\n.\r\n" + in expected_output == output + context "when passed content that DOES end in crlf" $ + it "will add only the '.CRLF' terminator" $ property $ \xs -> + let bs = BSC.pack $ xs <> crlf -- our input ends in crlf + output = runMockSmtp $ + sendRawMail "sender@s.com" ["recipient@r.com"] bs + expected_output = + "MAIL FROM:\r\n" + <> "RCPT TO:\r\n" + <> "DATA\r\n" + <> bs <> ".\r\n" + in expected_output == output + +-- `main` is here so that this module can be run from GHCi on its own. It is +-- not needed for automatic spec discovery. +main :: IO () +main = hspec spec + +spec :: Spec +spec = do + describe "executing sequences of MonadSmtp commands" $ + describe "should send expected ByteStrings" $ + forM_ testSequences $ \s@(descrip, _, _) -> + it descrip $ evalTestSeq s + dataSpec + sendRawMailSpec + diff --git a/test-hspec/hspec-tests.hs b/test-hspec/hspec-tests.hs new file mode 100644 --- /dev/null +++ b/test-hspec/hspec-tests.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test-other/doctest-tests.hs b/test-other/doctest-tests.hs new file mode 100644 --- /dev/null +++ b/test-other/doctest-tests.hs @@ -0,0 +1,79 @@ + +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} +{-# OPTIONS_GHC -fno-warn-type-defaults #-} + +module Main where + +import Data.Monoid +import Test.DocTest +import System.FilePath.Glob +import System.IO +import Shelly as Sh +import qualified Data.Text as T +import System.Environment + +-- Requires the test-doctests flag to be enabled, +-- and the STACK_RESOLVER environment variable to +-- be defined (specifying a resolver to use, e.g. +-- "lts-14"). + +default (T.Text) + +{-# ANN module ("HLint: ignore Eta reduce" :: String) #-} +{-# ANN module ("HLint: ignore Use camelCase" :: String) #-} + + +withText :: (String -> String) -> T.Text -> T.Text +withText f = T.pack . f . T.unpack + +get_packages :: Sh [T.Text] +get_packages = + do + let examplesDir = "examples" + T.words <$> run "ghc-pkg" ["list", "--simple-output", "--names-only"] + +bad_packages :: [T.Text] +bad_packages = [ + "cryptohash" + , "cryptohash-sha256" + ] + +-- | if they are present, try to hide packages +-- which will clash +get_package_hiding_opts :: Sh [String] +get_package_hiding_opts = do + packages <- get_packages + return $ concat + [ args | pkg <- packages, + pkg `elem` bad_packages, + let args = map T.unpack ["-hide-package", pkg]] + + +must_have_stack_resolver :: Sh () +must_have_stack_resolver = + get_env "STACK_RESOLVER" >>= \case + Nothing -> terror "STACK_RESOLVER env var not set, exiting" + Just{} -> return () + +main :: IO () +main = do + hSetBuffering stdout LineBuffering + args <- getArgs + putStrLn $ "\ndoctest-test. args: " ++ show args + package_hiding_opts <- shelly $ silently $ do + must_have_stack_resolver + -- hide some packages which are quite likely to be installed, + -- and which cause doctest to melt down with a + -- "Ambiguous module name ‘XXX’..." error. + get_package_hiding_opts + srcFiles <- globDir1 (compile "**/*.hs") "src" + putStrLn $ "source files being tested: " ++ show srcFiles + let doctestOpts :: [String] + doctestOpts = ["-isrc"] <> args + <> package_hiding_opts + putStrLn $ "docTestOpts: " ++ show doctestOpts + hFlush stdout + -- actually run tests + doctest $ doctestOpts ++ srcFiles +