assumpta-core (empty) → 0.1.0.0
raw patch · 16 files changed
+1705/−0 lines, 16 filesdep +Globdep +QuickCheckdep +assumpta-coresetup-changed
Dependencies added: Glob, QuickCheck, assumpta-core, attoparsec, base, base64-bytestring, bytestring, constraints, cryptonite, doctest, exceptions, hspec, memory, mtl, shelly, text, transformers
Files
- ChangeLog.md +7/−0
- LICENSE +24/−0
- README.md +57/−0
- Setup.hs +2/−0
- assumpta-core.cabal +144/−0
- src/Network/Mail/Assumpta/Auth.hs +110/−0
- src/Network/Mail/Assumpta/Connection.hs +67/−0
- src/Network/Mail/Assumpta/Instances.hs +53/−0
- src/Network/Mail/Assumpta/Mock.hs +61/−0
- src/Network/Mail/Assumpta/MonadSmtp.hs +438/−0
- src/Network/Mail/Assumpta/ParseResponse.hs +227/−0
- src/Network/Mail/Assumpta/Trans/Smtp.hs +139/−0
- src/Network/Mail/Assumpta/Types.hs +143/−0
- test-hspec/Network/Mail/Assumpta/MonadSmtpSpec.hs +153/−0
- test-hspec/hspec-tests.hs +1/−0
- test-other/doctest-tests.hs +79/−0
+ ChangeLog.md view
@@ -0,0 +1,7 @@+# Changelog for hs-smtp-client++## Unreleased changes++## 0.1.0.0++Unleashed on the world.
+ LICENSE view
@@ -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.
+ README.md view
@@ -0,0 +1,57 @@+# assumpta-core [](https://hackage.haskell.org/package/assumpta-ci) [](https://travis-ci.com/phlummox/assumpta-core) [](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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ assumpta-core.cabal view
@@ -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+ <https://hackage.haskell.org/package/assumpta 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+ <https://hackage.haskell.org/package/assumpta assumpta>+ package.+ .+ For further details, please see the README on GitHub at+ <https://github.com/phlummox/assumpta-core#readme>.+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
+ src/Network/Mail/Assumpta/Auth.hs view
@@ -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)++
+ src/Network/Mail/Assumpta/Connection.hs view
@@ -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+
+ src/Network/Mail/Assumpta/Instances.hs view
@@ -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)++
+ src/Network/Mail/Assumpta/Mock.hs view
@@ -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 <https://martinfowler.com/articles/mocksArentStubs.html>.)++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+
+ src/Network/Mail/Assumpta/MonadSmtp.hs view
@@ -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, <https://tools.ietf.org/html/rfc5321 RFC 5321>+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",+<https://tools.ietf.org/html/rfc1652 RFC 1652>) may relax this restriction for+the content body, content header fields are always encoded using US-ASCII.+See also <https://tools.ietf.org/html/rfc3030 RFC 3030>, "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 (\<CRLF>-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 +<https://hackage.haskell.org/package/mime-mail mime-mail>+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:\<sender\>@', expect 250.+mailFrom :: MonadSmtp m => ByteString -> m ()+mailFrom sender =+ unaryCommand MAIL sender >>+ expectCode 250++-- | Convenience func. +--+-- @rcptTo recipient@ will send '@RCPT TO:\<recipient\>@', 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 \<CRLF.CRLF>),+-- expect 354.+--+-- See <https://tools.ietf.org/html/rfc5321 RFC 5321> 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 \'@\<CRLF.CRLF>@' (i.e.,+-- a @\<CRLF>@, then a full stop on a line by itself,+-- then @\<CRLF>@. 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 +-- <https://tools.ietf.org/html/rfc5321 RFC 5321>,+-- 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 <https://tools.ietf.org/html/rfc5321 RFC 5321>,+-- 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 <https://tools.ietf.org/html/rfc5321 RFC 5321>,+-- 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 @\<CRLF>@, a+-- client must either reject the message as invalid or +-- add @\<CRLF>@ 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 @\<CRLF>@ in the RFC,+-- used to terminate all lines sent.+crlf :: Data.String.IsString p => p+crlf = "\r\n"+++
+ src/Network/Mail/Assumpta/ParseResponse.hs view
@@ -0,0 +1,227 @@++{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP #-}++{- |++Parse server replies.++The general format of replies is described in +<https://tools.ietf.org/html/rfc5321 RFC 5321>, 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 \<SP>, optionally some text, and \<CRLF>.++ 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+<https://en.wikipedia.org/wiki/List_of_SMTP_server_return_codes>.)+-}++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++-- | <https://hackage.haskell.org/package/attoparsec Attoparsec> 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 <https://tools.ietf.org/html/rfc5321 RFC 5321>, 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 @\<CRLF>@ 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 <SP>, 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) ++
+ src/Network/Mail/Assumpta/Trans/Smtp.hs view
@@ -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+
+ src/Network/Mail/Assumpta/Types.hs view
@@ -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+<https://tools.ietf.org/html/rfc5321 RFC 5321> for+more details):++* The protocol consists of /commands/ and /replies/.++* /Replies/ can be single-line or multiline.+ Single lines start with @\<reply-code> \<SP>@;+ for multiple lines, every line except the last+ starts with @\<reply-code> \'-'@, and the last+ is a single line.++ The @\<SP>@ 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 @\<SP>@ 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:\<somesender\@somedomain>@':+-- 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:<some-sender@my-org.com>"+-- >>> toByteString $ RCPT "delighted-recipient@dunder-mifflin.com"+-- "RCPT TO:<delighted-recipient@dunder-mifflin.com>"+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+++
+ test-hspec/Network/Mail/Assumpta/MonadSmtpSpec.hs view
@@ -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:<sender@s.com>\r\nRCPT TO:<recipient@r.com>\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:<sender@s.com>\r\nRCPT TO:<recipient@r.com>\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:<sender@s.com>\r\n"+ <> "RCPT TO:<recipient@r.com>\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:<sender@s.com>\r\n"+ <> "RCPT TO:<recipient@r.com>\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+
+ test-hspec/hspec-tests.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ test-other/doctest-tests.hs view
@@ -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+