Monad.hs

-- |
-- Module:     Network.Smtp.Monad
-- Copyright:  (c) 2010 Ertugrul Soeylemez
-- License:    BSD3
-- Maintainer: Ertugrul Soeylemez <es@ertes.de>
-- Stability:  experimental
--
-- This module implements a monad for SMTP sessions.

{-# LANGUAGE OverloadedStrings #-}

module Network.Smtp.Monad
    ( -- * Running sessions
      runMailT,
      runMailT_,

      -- * 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.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 =
    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 <- lift $ getField mailHandle
    run (enum $$ EB.iterHandle h) >>= either 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"]]


-- | Retrieve the next SMTP response.  Throw an 'Error', if there is no
-- next response.

nextResponse :: Monad m => MailT r m SmtpResponse
nextResponse = do
    let smtpError = throwError $ userError "Connection closed prematurely"
    EL.head >>= maybe smtpError return


-- | Run a mail session computation with the given output handle.  The
-- input is supplied by an 'Enumerator' such as 'enumHandleTimeout'.

runMailT :: (Applicative m, Monad m) =>
            Handle -> StringMailT (Either SomeException a) m a ->
            m (Either SomeException a)
runMailT h c =
    let cfg = MailConfig { mailExtensions = S.empty,
                           mailHandle = h }
    in evalStateT cfg . run $ c


-- | Run a mail session computation using 'runMailT' and throw an
-- exception on error.

runMailT_ :: (Applicative m, MonadIO m) =>
             Handle -> StringMailT (Either SomeException a) m a -> m a
runMailT_ h = runMailT h >=> either Ex.throwIO return