If you already got this message from me than please accept my
apologies for the spam.
This is a client that I hacked out of the original HAppS. I am sure
someone could do better but it should be something for you to chew on
at least. Best of all it works!
Parnell
{-# OPTIONS -fglasgow-exts #-}
module DSO.SMTPClient
(
Envelope(..), ezEnvelope, Address(..),Domain,
hostSend
) where
import Network
import Network.Socket
import Data.Dynamic
import Data.Char
import Data.Int
import Data.List
import Data.Typeable
import Control.Concurrent
import Control.Exception as E
import System.IO
import System.Environment
hPutLine :: Handle -> String -> IO ()
hPutLine handle line =
do
hPutStr handle $ line
hPutStr handle "\r\n"
hFlush handle
return ()
hGetLn :: Handle -> IO String
hGetLn handle = do
let hGetLn' = do
c <- hGetChar handle
case c of
'\n' -> do return []
'\r' -> do c2 <- hGetChar handle
if c2 == '\n' then return [] else getRest c
_ -> do getRest c
getRest c = do fmap (c:) hGetLn'
line <- hGetLn'
return line
ltrim = dropWhile isSpace
rtrim = reverse.ltrim.reverse
trim = ltrim.rtrim
split :: (a -> Bool) -> [a] -> ([a], [a])
split f s = (left, right)
where
(left,right')=break f s
right = if null right' then [] else tail right'
type Domain = String
data Address = Address {mailBox::String,domain::Domain} deriving
(Ord,Eq)
data Envelope msg = Envelope
{ relay :: Domain
, sender :: Address
, recipients :: [Address]
, contents :: msg
} deriving (Read, Show, Typeable)
ezEnvelope fromAddr toAddr contents =
Envelope "host" fromAddr [toAddr] contents
instance Show Address where
show (Address u d) = u++ '@' :d
instance Read Address where
readsPrec _ s = if isAddr then [(Address userId domain,rest)] else
[]
where
(userId,dr) = split (=='@') $ trim s
(domain, rest) = break(\x-> not $ isAlphaNum x || (x `elem`
"-_.")) dr
isAddr = not $ null userId || null domain
data SMTPState = RSET
| HELO Domain
| RCPTTO Domain Address [Address]
data SMTPError = SMTPError String deriving(Show, Typeable)
smtpErrorMajorCode :: SMTPError -> Int
smtpErrorMajorCode (SMTPError (e:_)) = fromEnum e - fromEnum '0'
smtpErrorMajorCode _ = -1
hostSend :: HostName -> Int -> Envelope String -> IO ()
hostSend host portNum msg = bracket (connectTo host (PortNumber $
fromIntegral portNum))
(\h -> hClose h `E.catch`(\_ -> return()))
(flip handleSend msg)
handleSend :: Handle -> Envelope String -> IO ()
handleSend smtpH msg = do
hGetLn smtpH >>= isReady
mapM_ (isAccept=<<) $
doLine smtpH ("HELO "++(relay msg)):
doLine smtpH ("MAIL FROM: <"++(show $ sender msg)++">") :
map (\addr->doLine smtpH $ "RCPT TO: <"++(show addr)++">")
(recipients msg)
isData =<< doLine smtpH "DATA"
hPutLine smtpH (contentData msg)
isAccept =<< doLine smtpH "."
isClose =<< doLine smtpH "QUIT"
where
isReady ('2':'2':'0':' ':_) = print "ISREADY" >> return ()
isReady msg = failure msg
isAccept ('2':'5':'0':' ':_) = return ()
isAccept ('2':'5':'1':' ':_) = return ()
isAccept msg = failure msg
isData ('3':'5':'4':' ':_)= return ()
isData msg = failure msg
isClose ('2':'2':'1':' ':_) = return ()
isClose msg = failure msg
failure s = do hPutLine smtpH "QUIT"
throwDyn $ SMTPError s
contentData msg = unlines $
map (\x->if x/=[] && head x=='.' then ('.':x) else
x) $
lines $ contents msg
doLine h line = hPutLine h line >> hGetLn h
>
http://www.cse.unsw.edu.au/~dons/git/HAppS-SMTP/(dons's repo, but