{- 
 Ver. 0.2

 Copyright (c) 2003, Massimo Zaniboni 
                     (email: massimo.zaniboni.74@virgilio.it) 
 All rights reserved.

Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are
met:

Redistributions of source code must retain the above copyright notice,
this list of conditions and the following disclaimer.  Redistributions
in binary form must reproduce the above copyright notice, this list of
conditions and the following disclaimer in the documentation and/or
other materials provided with the distribution.  Neither the name of
Massimo Zaniboni nor the names of its contributors may be used to
endorse or promote products derived from this software without
specific prior written permission.

THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

-}

module SMTPClient (
    sendStringAsEMail,
    SMTPAuthMethod(..)    
  ) 

where

import Data.List
import Data.Char

import Control.Monad
import Control.Exception

import System.IO
import System.Directory
import System.Time

import Network

import Base64


debugSMTP = False
-- ^ if True then display debug info


-- | SMTP authorization method
--
data SMTPAuthMethod = PlainSMTPAuth
                    | LoginSMTPAuth

-- | Send an email using a SMTP email server.
--
--
--  example = do
--   r <- sendStringAsEmail 
--                "pippo  "                  -- user
--                "pluto"                    -- password
--                PlainSMTPAuth              -- Auth method
--                "pippo@qwerty.org"         -- from
--                "paperina@qwerty.org"      -- to
--                "test"                     -- subject
--                ""                         -- cc
--                ""                         -- bcc
--                "mail.qwerty.org"          -- stmp_server
--                25                         -- default SMTP port
--                "localhost"                -- user domain 
--                "This is a test"           -- content
--                ["paperina@qwerty.org",    -- rcpt_lines
--                 "minni@qwery.it.it"]      
--
--  if r then do
--    putStrLn "Success"
--   else do
--    putStrLn "Fail"              
--
sendStringAsEMail ::   String
                       -- ^ user
                       -> String
                       -- ^ password
                       -> SMTPAuthMethod
                       -- ^ the Auth method to use
                       -> String 
                       -- ^ from
                       -> String
                       -- ^ to
                       -> String
                       -- ^ subject
                       -> String
                       -- ^ cc
                       -> String
                       -- ^ bcc
                       -> String
                       -- ^ smtp server
                       -> PortNumber
                       -- ^ smtp port
                       -> String
                       -- ^ helo domain (also "localhost")
                       -> String
                       -- ^ content
                       -> [String]
                       -- ^ target recipients 
		       -> IO (Bool)
		       -- ^ True if the EMAIL is sent

sendStringAsEMail user 
		  password 
		  authMethod 
		  from 
		  to 
		  subject 
		  cc 
		  bcc 
		  smtpServer 
		  smtpPort 
		  heloDomain 
		  content 
		  rcptLines = do 

 sfd <- smtpConnect smtpServer smtpPort
 finally (do
  c1  <- smtpEHLO sfd heloDomain
  
  if not c1 then return False
   else do 
    
    c1 <- case authMethod of
            PlainSMTPAuth -> smtpAuthenticatePlain sfd user password 
            LoginSMTPAuth -> smtpAuthenticateLogin sfd user password

    c2 <- smtpMailFrom sfd from
    c3 <- smtpRcptTo sfd rcptLines
    c4 <- smtpData sfd

    if (c1 && c2 && c3 && c4) then do
      sendSMTField sfd "Subject" subject
      sendSMTField sfd "From" from
      sendSMTField sfd "To" to
      sendSMTField sfd "Cc" cc
      sendSMTField sfd "Bcc" bcc
    
      hPutStr sfd "\r\n"

      sendContent sfd content      

      e1 <- smtpEOM sfd
      e2 <- smtpQuit sfd

      return (e1 && e2)
     else
      return False
  ) (do
     -- chiude le risorse
     smtpDisconnect sfd 
    )  
   
  where

    sendSMTField sfd header content = do  
      if content /= "" then do
        hPutStr sfd (header ++ ": " ++ content ++ "\r\n")  
        return ()
       else 
        return ()
   
    sendContent sfd content = do
      Control.Exception.catch (do  

        hPutStr sfd "\r\n"
   
        mapM_ (\line -> hPutStr sfd (adaptLineToSMP line)) (lines content)

        return True
       ) 
       (\exception ->  return False)

    adaptLineToSMP line = 
      let noReturns = filter (/= '\r') line
          validDot = if noReturns == "." then ".." else noReturns
      in  validDot ++ "\r\n"
    -- NOTE: because a "\r\n.\r\n" line is a end_of_content SMTP
    --       "\r\n..\r\n" stays for "\r\n.\r\n" content

smtpConnect :: String -> PortNumber -> IO Handle
smtpConnect smtp_server port = do
  sfd <- connectTo smtp_server (PortNumber port)
  return sfd

smtpDisconnect sfd = hClose sfd

smtpResponse :: Handle -> Bool -> IO Bool
smtpResponse sfd is_221_fatal = do
  (r,_) <- smtpResponseComplete sfd is_221_fatal
  return r

smtpResponseComplete :: Handle -> Bool -> IO (Bool,String)
smtpResponseComplete sfd is_221_fatal = do

  hFlush  sfd
  -- NOTE: force the send of previous SMTP command 

  line <- hGetLine sfd

  if debugSMTP then do
    putStrLn ("response: " ++ line)
    return ()
   else do return ()
  
  (r, realLine) <- if (length line < 3) then return (False, line)
   else 
    if ((line !! 3) == '-') then smtpResponseComplete sfd is_221_fatal
     else 
      if (any (\fatalCode -> isPrefixOf fatalCode line) fatal) then return (False, line)
       else if (any (\notifyCode -> isPrefixOf notifyCode line) notify) then return (True, line)
        else if (any (\okCode -> isPrefixOf okCode line) ok) then return (True, line)
         else return (False, line)

  return (r,realLine)
    
  where
  
    fatal = ["421", "432", "450", "451",
             "452", "454", "500", "501",
             "502", "503", "504", "530",
             "534", "535", "538", "550",
             "552", "553", "554"
            ] ++ (if is_221_fatal then ["221"] else [])

    notify = ["211", "214", "251", "252",
              "551"] 

    ok = ["220", "221", "235", "250",
          "334", "354" ]
    

smtpEHLO sfd helo_domain = do
  (_, heloLine) <- smtpResponseComplete sfd True
  -- read off the greeting
  
  hPutStr sfd ("EHLO " ++ "localhost" ++ "\r\n")

  r <- smtpResponse sfd True

  return r
 where
  heloDomain heloLine = takeWhile (/= ' ') (tail (dropWhile (/= ' ') heloLine))   

smtpAuthenticatePlain sfd user password = do
  hPutStr sfd "AUTH PLAIN "
  hPutStr sfd ((Base64.encode ("\0"++user++"\0"++password))++"\r\n")
  r <- smtpResponse sfd True
  return r

smtpAuthenticateLogin sfd user password = do

  hPutStr sfd "AUTH LOGIN\r\n"
  e1 <- smtpResponse sfd True

  r <- if e1 then do
    hPutStr sfd (Base64.encode user)
    e2 <- smtpResponse sfd True
    if e2 then do
      hPutStr sfd (Base64.encode password)
      e3 <- smtpResponse sfd True
      return e3
     else return False
   else return False

  return r

smtpMailFrom sfd from = do
  hPutStr sfd ("MAIL FROM: <" ++ from ++ ">\r\n")
  
  r <- smtpResponse sfd True
  return r

smtpQuit sfd = do
  hPutStr sfd ("QUIT" ++ "\r\n")
  
  r <- smtpResponse sfd False
  return r

smtpRset sfd = do
  hPutStr sfd ("RSET" ++ "\r\n")
  
  r <- smtpResponse sfd False
  
  return r

smtpData sfd = do
  hPutStr sfd ("DATA" ++ "\r\n")
  r <- smtpResponse sfd False
  return r  

smtpRcptTo :: Handle -> [String] -> IO (Bool)
smtpRcptTo sfd addressList = do
  result <- foldM (addAddress) (True) addressList
  return result
  where
    addAddress result address = do
      hPutStr sfd ("RCPT TO: <" ++ address ++">\r\n")
      e <- smtpResponse sfd True
      if e == False then return False
       else return result	   

-- Send End of Message
--
smtpEOM sfd = do
  hPutStr sfd ("\r\n.\r\n")
  smtpResponse sfd True


