Monad.hs

-- |
-- Module:     Network.Smtp.Monad
-- Copyright:  (c) 2011 Ertugrul Soeylemez
-- License:    BSD3
-- Maintainer: Ertugrul Soeylemez <es@ertes.de>
--
-- 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