module Network.SMTP.ClientSession (
smtpClientSession,
SMTPState(..),
SmtpReply(..),
SmtpCode(..),
SuccessCode(..),
Category(..),
Message,
GenericMessage(..),
Field(..),
NameAddr(..)
) where
import Text.ParserCombinators.Parsec.Rfc2821 (
SmtpReply(..),
SmtpCode(..),
SuccessCode(..),
Category(..),
reply
)
import Text.ParserCombinators.Parsec.Rfc2822 (
Message(..),
GenericMessage(..),
Field(..),
NameAddr(..)
)
import Data.Maybe
import qualified Data.Set as Set
import Prelude hiding (fail)
import Data.List
import System.Time
import System.Locale
data SMTPState = SMTPState {
smtpOutQueue :: [String],
smtpSuccess :: Bool,
smtpFailure :: Maybe String,
smtpReceive :: String -> SMTPState -> SMTPState,
smtpStatuses :: [Maybe SmtpReply]
}
send :: String -> (SMTPState -> SMTPState) -> SMTPState -> SMTPState
send txt cont state =
cont $
state {
smtpOutQueue = txt:smtpOutQueue state
}
nullReceive :: String -> SMTPState -> SMTPState
nullReceive _ state = state
receive :: (String -> SMTPState -> SMTPState) -> SMTPState -> SMTPState
receive cont state =
state {
smtpOutQueue = reverse $ smtpOutQueue state,
smtpReceive = \line state -> cont line $ state {
smtpOutQueue = [],
smtpReceive = nullReceive
}
}
fail :: String -> SMTPState -> SMTPState
fail errorText state =
state {
smtpOutQueue = [],
smtpFailure = Just errorText
}
success :: SMTPState -> SMTPState
success state =
state {
smtpOutQueue = [],
smtpSuccess = True
}
equals :: SuccessCode -> Category -> SmtpReply -> Bool
equals code cat reply =
case reply of
Reply (Code gotCode gotCat _) _ | gotCode == code && gotCat == cat -> True
otherwise -> False
check :: (SmtpReply -> Bool) -> String -> SmtpReply -> (SMTPState -> SMTPState) -> SMTPState -> SMTPState
check isOK descr reply cont =
if isOK reply
then cont
else
fail $ "SMTP error: got "++
(cleanUp $ show reply)++
" when I expected "++descr
cleanUp :: String -> String
cleanUp =
map (\x -> if x == '\n' then '/' else x) .
reverse .
dropWhile (\x -> x == '\n') .
reverse .
filter (/= '\r')
maybeRead :: Read a => String -> Maybe a
maybeRead s = case reads s of
[(x, "")] -> Just x
_ -> Nothing
for :: [a]
-> (a -> (SMTPState -> SMTPState) -> SMTPState -> SMTPState)
-> (SMTPState -> SMTPState)
-> SMTPState -> SMTPState
for [] _ cont = cont
for (x:xs) body cont =
body x $
for xs body cont
putStatuses :: [Maybe SmtpReply] -> (SMTPState -> SMTPState) -> SMTPState -> SMTPState
putStatuses statuses cont state = cont $ state {smtpStatuses = statuses}
receiveReply :: (SmtpReply -> SMTPState -> SMTPState) -> SMTPState -> SMTPState
receiveReply cont =
rec [] $ \revMsgs@(final:_) ->
if length final < 4 || final !! 3 /= ' ' then
fail ("malformed SMTP reply: "++final)
else
case maybeRead (take 3 final) of
Just code ->
cont $ mkReply code (reverse $ map (drop 4) revMsgs)
Nothing ->
fail ("Malformed SMTP reply: "++final)
where
rec :: [String] -> ([String] -> SMTPState -> SMTPState) -> SMTPState -> SMTPState
rec msgs cont =
receive $ \line ->
if length line < 4 then
fail ("malformed SMTP reply: "++line)
else if line !! 3 == '-' then
rec (line:msgs) cont
else
cont (line:msgs)
mkReply :: Int -> [String] -> SmtpReply
mkReply code msgs = reply (code `div` 100) ((code `div` 10) `mod` 10) (code `mod` 10) msgs
equalsMailOK :: SmtpReply -> Bool
equalsMailOK = equals Success MailSystem
checkMailOK :: (SMTPState -> SMTPState) -> SMTPState -> SMTPState
checkMailOK cont =
receiveReply $ \reply ->
check equalsMailOK "\"mail system OK\" (code 25x)" reply $
cont
checkConnectionOK :: (SMTPState -> SMTPState) -> SMTPState -> SMTPState
checkConnectionOK cont =
receiveReply $ \reply ->
check (equals Success Connection) "\"connection OK\" (code 22x)" reply $
cont
equalsDataOK :: SmtpReply -> Bool
equalsDataOK = equals IntermediateSuccess MailSystem
smtpClientSession :: String
-> [Message]
-> SMTPState
smtpClientSession domain messages = talk domain messages $ SMTPState {
smtpOutQueue = [],
smtpReceive = nullReceive,
smtpSuccess = False,
smtpFailure = Nothing,
smtpStatuses = []
}
talk :: String -> [Message] -> SMTPState -> SMTPState
talk domain messages =
checkConnectionOK $
send ("EHLO "++domain) $
checkMailOK $
sendMessages messages [] $
send "QUIT" $
checkConnectionOK $
success
where
sendMessages :: [Message] -> [Maybe SmtpReply] -> (SMTPState -> SMTPState) -> SMTPState -> SMTPState
sendMessages [] _ cont = cont
sendMessages (message:rest) statuses cont =
sendMessage message $ \status ->
let statuses' = status:statuses in
putStatuses (reverse statuses') $
sendMessages rest statuses' cont
sendMessage :: Message -> (Maybe SmtpReply -> SMTPState -> SMTPState) -> SMTPState -> SMTPState
sendMessage message cont =
let Message fields _ = message
froms = map (\(NameAddr _ addr) -> addr) $
concatMap (\f ->
case f of
From from -> from
_ -> []) fields
tos = map (\(NameAddr _ addr) -> addr) $
concatMap (\f ->
case f of
To to -> to
Cc to -> to
Bcc to -> to
_ -> []) fields in
if null froms then
fail "email contains no From: field"
else if null tos then
fail "email contains no To:, Cc: or Bcc: field"
else (
send ((("MAIL FROM:"++) . angle_addr (head froms)) "") $
receiveReply $ \reply ->
if not $ equalsMailOK reply then
cont (Just reply)
else (
for tos (\to next ->
send ((("RCPT TO:"++) . angle_addr to) "") $
receiveReply $ \reply ->
if not $ equalsMailOK reply
then cont (Just reply)
else next
) $
send "DATA" $
receiveReply $ \reply ->
if not $ equalsDataOK reply then
cont (Just reply)
else (
let msgLines = formatMessage message in
for msgLines (\line cont ->
send (if line == "." then ". " else line) $
cont
) $
send "." $
receiveReply $ \reply ->
if not $ equalsMailOK reply then
cont (Just reply)
else
cont Nothing
)
)
)
atext_alphabet = Set.fromList $
"abcdefghijklmnopqrstuvwxyz"++
"ABCDEFGHIJKLMNOPQRSTUVWXYZ"++
"0123456789"++
"!#$%&'*+-/=?^_`{|}~"
atomAllowed :: String -> Bool
atomAllowed "" = False
atomAllowed txt = all (`Set.member` atext_alphabet) txt
dotAtomAllowed :: String -> Bool
dotAtomAllowed str =
let (at, rest) = break (== '.') str in
if not $ atomAllowed at then
False
else
if null rest then
True
else
dotAtomAllowed (tail rest)
addr_spec :: String -> ShowS
addr_spec addr =
let (local, at_domain) = break (=='@') addr
domain = if "@" `isPrefixOf` at_domain then tail at_domain else at_domain in
dotatom_or_quoted local . ("@"++) . dotatom_or_domain_literal domain
angle_addr :: String -> ShowS
angle_addr addr =
("<"++) . addr_spec addr . (">"++)
msg_id :: String -> ShowS
msg_id mid = angle_addr mid
atom_or_quoted :: String -> ShowS
atom_or_quoted text =
if atomAllowed text then
(text++)
else
quoted_string text
phrase = atom_or_quoted
display_name = phrase
dotatom_or_quoted :: String -> ShowS
dotatom_or_quoted text =
if dotAtomAllowed text then
(text++)
else
quoted_string text
quoted_string :: String -> ShowS
quoted_string text = ("\""++) . (quoted_ text++) . ("\""++)
where
quoted_ [] = []
quoted_ (x:xs) =
case x of
'\\' -> '\\':'\\':quoted_ xs
'"' -> '\\':'"':quoted_ xs
_ -> x:quoted_ xs
dotatom_or_domain_literal :: String -> ShowS
dotatom_or_domain_literal text =
if dotAtomAllowed text then
(text++)
else
domain_literal text
domain_literal :: String -> ShowS
domain_literal text = ("["++) . (quoted_ text++) . ("]"++)
where
quoted_ [] = []
quoted_ (x:xs) =
case x of
'\\' -> '\\':'\\':quoted_ xs
'[' -> '\\':'[':quoted_ xs
']' -> '\\':']':quoted_ xs
_ -> x:quoted_ xs
name_addr :: NameAddr -> ShowS
name_addr (NameAddr mName addr) =
(case mName of
Just name -> display_name name . (" "++)
Nothing -> id) .
angle_addr addr
address_list :: [NameAddr] -> ShowS
address_list addrs =
foldr (.) id $ intersperse (",\n"++) $ map name_addr addrs
formatMessage :: Message -> [String]
formatMessage (Message fields body) =
concatMap (indent . formatField) fields ++
[""] ++
map (reverse . dropWhile (=='\r') . reverse) (lines body)
indent :: String -> [String]
indent text =
case lines text of
[] -> []
(l:ls) -> l:map (" "++) ls
formatField :: Field -> String
formatField (OptionalField name value) = name ++ ": " ++ value
formatField (From addrs) = (("From: "++) . address_list addrs) ""
formatField (Sender addr) = (("From: "++) . name_addr addr) ""
formatField (ReturnPath txt) = "Return-Path: "++txt
formatField (ReplyTo addrs) = (("Reply-To: "++) . address_list addrs) ""
formatField (To addrs) = (("To: "++) . address_list addrs) ""
formatField (Cc addrs) = (("Cc: "++) . address_list addrs) ""
formatField (Bcc addrs) = (("Bcc: "++) . address_list addrs) ""
formatField (MessageID mid) = (("Message-ID: "++) . msg_id mid) ""
formatField (InReplyTo mids) = (("In-Reply-To: "++) . foldr (.) id (map msg_id mids)) ""
formatField (References mids) = (("References: "++) . foldr (.) id (map msg_id mids)) ""
formatField (Subject txt) = "Subject: "++txt
formatField (Comments txt) = "Comments: "++txt
formatField (Keywords kws) = (("Keywords: "++) . foldr (.) id (intersperse (",\n"++) $ map phrase (concat kws))) ""
formatField (Date date) = "Date: "++formatDate date
formatField (ResentDate date) = "Resent-Date: "++formatDate date
formatField (ResentFrom addrs) = (("Resent-From: "++) . address_list addrs) ""
formatField (ResentSender addr) = (("Resent-From: "++) . name_addr addr) ""
formatField (ResentTo addrs) = (("Resent-To: "++) . address_list addrs) ""
formatField (ResentCc addrs) = (("Resent-Cc: "++) . address_list addrs) ""
formatField (ResentBcc addrs) = (("Resent-Bcc: "++) . address_list addrs) ""
formatField (ResentMessageID mid) = (("Resent-Message-ID: "++) . msg_id mid) ""
formatField (ResentReplyTo addrs) = (("Resent-Reply-To: "++) . address_list addrs) ""
formatField (Received (ps, date)) = (("Received: "++) . pairs ps . (";"++) . (formatDate date++)) ""
formatField (ObsReceived ps) = (("Received: "++) . pairs ps) ""
formatDate :: CalendarTime -> String
formatDate ct = formatCalendarTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S " ct ++ formatTimeZone (ctTZ ct)
formatTimeZone :: Int -> String
formatTimeZone offset =
if offset < 0 then
"-"++ftz (offset)
else
"+"++ftz offset
where
ftz offset = dig2 (offset `div` 3600) ++ dig2 ((offset `div` 60) `mod` 60)
dig2 n = (\n -> if n < 10 then "0"++show n else show n) (n `mod` 100)
pairs :: [(String, String)] -> ShowS
pairs ps = foldr (.) id $ intersperse ("\n"++) $ map pair ps
where
pair (name, value) =
(name++) . (" "++) . (value++)