Types.hs

-- |
-- Module:     Network.Smtp.Types
-- Copyright:  (c) 2011 Ertugrul Soeylemez
-- License:    BSD3
-- Maintainer: Ertugrul Soeylemez <es@ertes.de>
--
-- Types used by ismtp.

{-# LANGUAGE
  DeriveDataTypeable,
  FlexibleInstances #-}

module Network.Smtp.Types
    ( -- * Mail monads
      MailMonad(..),
      Mail,
      MailT,

      -- * SMTP service extensions
      Extension(..),
      AuthMethod(..),

      -- * Other types
      MailConfig(..),
      SmtpCommand(..),
      SmtpException(..),
      SmtpResponse(..)
    )
    where

import Control.ContStuff
import Control.Exception as Ex
import Data.ByteString (ByteString)
import Data.Enumerator
import Data.Set (Set)
import Data.Typeable
import Data.Vector (Vector)
import System.IO
import Text.Printf


-- | Mail configuration state monad.  Minimal complete definition:
-- 'mapMailConfig'.

class (Functor m, Monad m) => MailMonad m where
    -- | Get the current mail configuration.
    getMailConfig :: m MailConfig
    getMailConfig = mapMailConfig id

    -- | Get supported SMTP service extensions.
    getMailExtensions :: m (Set Extension)
    getMailExtensions = mailExtensions <$> getMailConfig

    -- | Get mail handle.
    getMailHandle :: m Handle
    getMailHandle = mailHandle <$> getMailConfig

    -- | Get write timeout for mail session in milliseconds.
    getMailWriteTimeout :: m Int
    getMailWriteTimeout = mailWriteTimeout <$> getMailConfig

    -- | Map over the current mail configuration with the given function
    -- and return the new configuration.
    mapMailConfig :: (MailConfig -> MailConfig) -> m MailConfig

    -- | Modify the current mail configuration.
    modifyMailConfig :: (MailConfig -> MailConfig) -> m ()
    modifyMailConfig = (() <$) . mapMailConfig

    -- | Set the current mail configuration.
    putMailConfig :: MailConfig -> m ()
    putMailConfig cfg = modifyMailConfig (const cfg)

    -- | Set the set of supported SMTP service extensions.
    setMailExtensions :: Set Extension -> m ()
    setMailExtensions exts =
        modifyMailConfig (\cfg -> cfg { mailExtensions = exts })

    -- | Set the ouput handle.
    setMailHandle :: Handle -> m ()
    setMailHandle h = modifyMailConfig (\cfg -> cfg { mailHandle = h })

    -- | Modify the mail write timeout.
    setMailWriteTimeout :: Int -> m ()
    setMailWriteTimeout timeout =
        modifyMailConfig (\cfg -> cfg { mailWriteTimeout = timeout })

instance MailMonad (StateT r MailConfig m) where
    mapMailConfig f =
        StateT $ \k s0 ->
            let s1 = f s0 in k s1 s1


-- | Authentication methods for the SMTP authentication extension.

data AuthMethod
    = AuthMethod  -- ^ We don't know any authentication methods yet.
    deriving (Eq, Ord, Read, Show)


-- | SMTP service extension.

data Extension
    = AuthExt (Set AuthMethod)  -- ^ Authentication extension.
    deriving (Eq, Ord, Read, Show)


-- | The 'MailT' monad transformer encapsulates an SMTP session.

type MailT r m = Iteratee SmtpResponse (StateT r MailConfig m)


-- | The 'Mail' monad is 'MailT' over 'IO'.

type Mail r = MailT r IO


-- | Mail session configuration.

data MailConfig =
    MailConfig {
      mailExtensions   :: Set Extension,  -- ^ Supported extensions.
      mailHandle       :: Handle,         -- ^ Connection handle.
      mailWriteTimeout :: Int             -- ^ Write timeout in milliseconds.
    }


-- | Failed SMTP command (used by 'SmtpException').

data SmtpCommand
    = SmtpDataCmd                 -- ^ DATA.
    | SmtpHelloCmd ByteString     -- ^ EHLO or HELO with domain.
    | SmtpMailFromCmd ByteString  -- ^ MAIL FROM with address.
    | SmtpQuitCmd                 -- ^ QUIT.
    | SmtpRcptToCmd ByteString    -- ^ RCPT TO with address.
    | SmtpResetCmd                -- ^ RSET.
    | SmtpVerifyCmd ByteString    -- ^ VRFY with the given user name.
    | SmtpWelcomeCmd              -- ^ Waiting for welcome message.


-- | SMTP exception.

data SmtpException
    = SmtpNetworkError {
        smtpErrorMessage :: String
      }
    | SmtpSessionError {
        smtpErrorMessage       :: String,
        smtpErrorCommand       :: SmtpCommand,
        smtpErrorCode          :: Integer,
        smtpErrorServerMessage :: String
      }

    deriving Typeable

instance Ex.Exception SmtpException

instance Show SmtpException where
    show (SmtpNetworkError msg) = "SMTP network error: " ++ msg
    show (SmtpSessionError msg _ code srvMsg) =
        printf "%s (%i): \"%s\"" msg code srvMsg


-- | SMTP response.

data SmtpResponse =
    SmtpResponse {
      smtpCode     :: Integer,           -- ^ Three digit response code.
      smtpMessages :: Vector ByteString  -- ^ Messages sent with the code.
    }
    deriving (Eq, Show)