Session.hs

-- |
-- Module:     Network.Smtp.Session
-- Copyright:  (c) 2011 Ertugrul Soeylemez
-- License:    BSD3
-- Maintainer: Ertugrul Soeylemez <es@ertes.de>
--
-- SMTP session computations.

{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}

module Network.Smtp.Session
    ( -- * Initialization
      hello,
      mailData,
      mailDataStr,
      mailFrom,
      quit,
      rcptTo,
      reset,
      verify,
      waitForWelcome
    )
    where

import qualified Data.Set as S
import qualified Data.Vector as V
import Control.ContStuff
import Data.ByteString (ByteString)
import Data.Enumerator as E
import Data.List as L
import Data.Maybe
import Network.Smtp.Monad
import Network.Smtp.Tools
import Network.Smtp.Types


-- | Try /EHLO/ with fallback to /HELO/.

hello :: forall m. (MailMonad m, MonadIO m) => ByteString -> Iteratee SmtpResponse m ()
hello domain = do
    mailPutLn ["EHLO ", domain]
    SmtpResponse code msgs <- nextResponse
    let exts = S.fromList . catMaybes . L.map stringToExtension .
               L.drop 1 . V.toList $ msgs

    case code of
      250 -> lift $ setMailExtensions exts
      500 -> tryHelo
      502 -> tryHelo
      554 -> tryHelo
      _   -> mailError (SmtpHelloCmd domain) "EHLO rejected" code msgs

    where
    tryHelo :: Iteratee SmtpResponse m ()
    tryHelo = do
        mailPutLn ["HELO ", domain]
        SmtpResponse code msgs <- nextResponse
        case code of
          250 -> return ()
          _   -> mailError (SmtpHelloCmd domain) "HELO rejected" code msgs


-- | Send the /DATA/ command along with the mail content.  Please note
-- that the last line must be properly terminated by CRLF.

mailData ::
    (MailMonad m, MonadIO m) =>
    Enumerator ByteString (Iteratee SmtpResponse m) () ->
    Iteratee SmtpResponse m ()
mailData enumMail = do
    mailPutLn ["DATA"]
    SmtpResponse code msgs <- nextResponse
    case code of
      354 -> do
          mailPut (enumMail >==> enumList 1 [".\r\n"])
          SmtpResponse code2 msgs2 <- nextResponse
          case code2 of
            250 -> return ()
            _   -> mailError SmtpDataCmd "Mail data rejected" code2 msgs2
      _ -> mailError SmtpDataCmd "Mail rejected" code msgs


-- | 'ByteString' interface to 'mailData'.

mailDataStr :: (MailMonad m, MonadIO m) => ByteString -> Iteratee SmtpResponse m ()
mailDataStr = mailData . enumList 1 . (:[])


-- | Send /MAIL FROM/ command.

mailFrom :: (MailMonad m, MonadIO m) => ByteString -> Iteratee SmtpResponse m ()
mailFrom from = do
    mailPutLn ["MAIL FROM:<", from, ">"]
    SmtpResponse code msgs <- nextResponse
    case code of
      250 -> return ()
      _   -> mailError (SmtpMailFromCmd from) "MAIL FROM rejected" code msgs


-- | Send /QUIT/ command.  Please note:  This iteratee violates the
-- standard by recognizing a 250 result code as success.

quit :: (MailMonad m, MonadIO m) => Iteratee SmtpResponse m ()
quit = do
    mailPutLn ["QUIT"]
    SmtpResponse code msgs <- nextResponse
    case code of
      221 -> return ()
      250 -> return ()
      _   -> mailError SmtpQuitCmd "Quit rejected" code msgs


-- | Send /RCPT TO/ command.

rcptTo :: (MailMonad m, MonadIO m) => ByteString -> Iteratee SmtpResponse m ()
rcptTo to = do
    mailPutLn ["RCPT TO:<", to, ">"]
    SmtpResponse code msgs <- nextResponse
    case code of
      250 -> return ()
      _   -> mailError (SmtpRcptToCmd to) "RCPT TO rejected" code msgs


-- | Send /RSET/ command.

reset :: (MailMonad m, MonadIO m) => Iteratee SmtpResponse m ()
reset = do
    mailPutLn ["RSET"]
    SmtpResponse code msgs <- nextResponse
    case code of
      250 -> return ()
      _   -> mailError SmtpResetCmd "RSET rejected" code msgs


-- | Send the /VRFY/ command to find out, whether the mail exchangers
-- knows the given user.  Nowadays most mail exchangers disable this
-- command for security reasons.
--
-- Please note that many SMTP servers will give you false positives or
-- false negatives to prevent spamming attempts.  It is not recommended
-- to use this command.

verify :: (MailMonad m, MonadIO m) => ByteString -> Iteratee SmtpResponse m Bool
verify checkUser = do
    mailPutLn ["VRFY ", checkUser]
    SmtpResponse code msgs <- nextResponse
    case code of
      250 -> return True
      550 -> return False
      _   -> mailError (SmtpVerifyCmd checkUser) "VRFY rejected" code msgs


-- | Wait for the welcome greeting from the SMTP server.

waitForWelcome :: MailMonad m => Iteratee SmtpResponse m ()
waitForWelcome = do
    SmtpResponse code msgs <- nextResponse
    case code of
      220 -> return ()
      _   -> mailError SmtpWelcomeCmd "We're not welcome" code msgs