implementation module Email import StdTCPChannels import StdIO, StdTuple, StdInt, StdList // Send function which sends the e-mail out sendEmail :: [EmailOption] Email *World -> (Bool,*World) sendEmail options email world // Lookup ip address of SMTP server # (mbIp, world) = lookupIPAddress (getSMTPServerOpt options) world | isNothing mbIp = (False,world) // Connect to the SMTP server # (tReport, mbDuplex, world) = connectTCP_MT Nothing ((fromJust mbIp),25) world | tReport <> TR_Success = (False,world) # {sChannel, rChannel} = fromJust mbDuplex // Read welcome message # (msg, rChannel, world) = receive rChannel world | statusCode msg <> 220 = (False,world) // Send HELO command # (sChannel, world) = send (toByteSeq mkSMTPHelo) sChannel world # (msg, rChannel, world) = receive rChannel world // Send FROM command # (sChannel, world) = send (toByteSeq (mkSMTPFrom email)) sChannel world # (msg, rChannel, world) = receive rChannel world | statusCode msg <> 250 = (False,world) // Send TO command # (sChannel, world) = send (toByteSeq (mkSMTPTo email)) sChannel world # (msg, rChannel, world) = receive rChannel world | statusCode msg <> 250 = (False,world) // Send DATA command # (sChannel, world) = send (toByteSeq mkSMTPData) sChannel world # (msg, rChannel, world) = receive rChannel world | statusCode msg <> 354 = (False,world) // Send body # (sChannel, world) = send (toByteSeq (mkSMTPBody email)) sChannel world # (msg, rChannel, world) = receive rChannel world | statusCode msg <> 250 = (False,world) // Send QUIT command # (sChannel, world) = send (toByteSeq mkSMTPQuit) sChannel world # (msg, rChannel, world) = receive rChannel world //Ignore this reply, we are done anyway // Disconnect (the server should have already done this) # world = closeChannel sChannel world # world = closeRChannel rChannel world = (True,world) // SMTP Protocol handling functions // Make the SMTP Helo command mkSMTPHelo :: String mkSMTPHelo = "HELO localhost\r\n" // Make the SMTP From command mkSMTPFrom :: Email -> String mkSMTPFrom email = "MAIL FROM:<" +++ (cleanupEmailString email.email_from) +++ ">\r\n" // Make the SMTP To command mkSMTPTo :: Email -> String mkSMTPTo email = "RCPT TO:<" +++ (cleanupEmailString email.email_to) +++ ">\r\n" // Make the SMTP Data command mkSMTPData :: String mkSMTPData = "DATA\r\n" // Make the SMTP message body that is sent after the message mkSMTPBody :: Email -> String mkSMTPBody email = "From: " +++ (cleanupEmailString email.email_from) +++ "\r\n" +++ "To: " +++ (cleanupEmailString email.email_to) +++ "\r\n" +++ "Subject: " +++ (cleanupEmailString email.email_subject) +++ "\r\n" +++ "\r\n" +++ email.email_body +++ "\r\n.\r\n" mkSMTPQuit :: String mkSMTPQuit = "QUIT\r\n" //Utility functions getSMTPServerOpt :: [EmailOption] -> String getSMTPServerOpt [] = "localhost" //Default is localhost getSMTPServerOpt [EmailOptSMTPServer s:xs] = s getSMTPServerOpt [x:xs] = getSMTPServerOpt xs //Parse the reply of the server into a status code statusCode :: ByteSeq -> Int statusCode msg = toInt ((toString msg) % (0,2)) //Strip any newline chars and tabs from a string. cleanupEmailString :: String -> String cleanupEmailString s = toString (filter (\x -> not (isMember x ['\r\n\t'])) (fromString s))