-- | -- Module: Network.Smtp.Monad -- Copyright: (c) 2011 Ertugrul Soeylemez -- License: BSD3 -- Maintainer: Ertugrul Soeylemez -- -- This module implements a monad for SMTP sessions. {-# LANGUAGE OverloadedStrings #-} module Network.Smtp.Monad ( -- * Running sessions runMailT, -- * Manipulating sessions mailSetWriteTimeout, -- * Utility functions mailError, mailPut, mailPutLn, nextResponse ) where import qualified Data.Set as S import Control.ContStuff --import Control.Exception.Peel as Ex import Data.ByteString (ByteString) import Data.ByteString.Char8 () import Data.Enumerator as E --import Data.Enumerator.Binary as EB import Data.Enumerator.List as EL import Data.Enumerator.NetLines import Data.Vector (Vector) import Network.Smtp.Tools import Network.Smtp.Types import System.IO -- | Format a bad response together with the supplied error message and -- throw an 'SmtpException' in the underlying 'Iteratee'. mailError :: Monad m => SmtpCommand -> String -> Integer -> Vector ByteString -> MailT r m a mailError cmd errMsg code msgs = lift . throwError $ SmtpException errMsg cmd code (formatMsgs msgs) -- | Send a stream of 'ByteString's to the SMTP server. mailPut :: MonadIO m => Enumerator ByteString (MailT r m) () -> MailT r m () mailPut enum = do h <- getField mailHandle timeout <- getField mailWriteTimeout run (enum $$ iterHandleTimeout timeout h) >>= either (lift . throwError) return -- | Send a list of 'ByteString's followed an SMTP line terminator to -- the SMTP server. mailPutLn :: MonadIO m => [ByteString] -> MailT r m () mailPutLn strs = mailPut $ concatEnums [enumList 16 strs, enumList 1 ["\r\n"]] -- | Set the write timeout for the current mail session in milliseconds. mailSetWriteTimeout :: Int -> MailT r m () mailSetWriteTimeout timeout = modify (\cfg -> cfg { mailWriteTimeout = timeout }) -- | Retrieve the next SMTP response. Throw an 'Error', if there is no -- next response. nextResponse :: Monad m => MailT r m SmtpResponse nextResponse = lift $ do let smtpError = throwError $ userError "Connection closed prematurely" EL.head >>= maybe smtpError return -- | Run a mail session computation with the given protocol line length -- limit (first argument), response lines limit (second argument) and -- output handle. The input is supplied by an 'Enumerator' such as -- 'enumHandleTimeout'. -- -- The inner iteratee uses 'SmtpResponse' as its input type and hence -- expects the 'netLines' and 'smtpResponses' enumeratees to be applied. -- This is done by 'runMailT' for you, so the resulting iteratee takes a -- raw 'ByteString' stream as input. runMailT :: (Applicative m, Monad m) => Int -> Int -> Handle -> MailT a m a -> Iteratee ByteString m a runMailT maxLine maxMsgs h c = let cfg = MailConfig { mailExtensions = S.empty, mailHandle = h, mailWriteTimeout = 15000 } in netLines maxLine =$ smtpResponses maxMsgs =$ evalStateT cfg c