moparisthebest/Simba
1
0
Fork 0
mirror of https://github.com/moparisthebest/Simba synced 2024-12-15 20:12:21 -05:00
Code Issues Releases Wiki Activity
278ab8d88b
Simba/trunk/Units/Synapse/smtpsend.pas

720 lines
24 KiB
ObjectPascal
Raw Blame History

{==============================================================================|
| Project : Ararat Synapse | 003.005.000 |
|==============================================================================|
| Content: SMTP client |
|==============================================================================|
| Copyright (c)1999-2009, Lukas Gebauer |
| 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 Lukas Gebauer 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 REGENTS 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. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c) 1999-2009. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
|==============================================================================|
| History: see HISTORY.HTM from distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
{:@abstract(SMTP client)
Used RFC: RFC-1869, RFC-1870, RFC-1893, RFC-2034, RFC-2104, RFC-2195, RFC-2487,
RFC-2554, RFC-2821
}
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$H+}
unit smtpsend;
interface
uses
SysUtils, Classes,
blcksock, synautil, synacode;
const
cSmtpProtocol = '25';
type
{:@abstract(Implementation of SMTP and ESMTP procotol),
include some ESMTP extensions, include SSL/TLS too.
Note: Are you missing properties for setting Username and Password for ESMTP?
Look to parent @link(TSynaClient) object!
Are you missing properties for specify server address and port? Look to
parent @link(TSynaClient) too!}
TSMTPSend = class(TSynaClient)
private
FSock: TTCPBlockSocket;
FResultCode: Integer;
FResultString: string;
FFullResult: TStringList;
FESMTPcap: TStringList;
FESMTP: Boolean;
FAuthDone: Boolean;
FESMTPSize: Boolean;
FMaxSize: Integer;
FEnhCode1: Integer;
FEnhCode2: Integer;
FEnhCode3: Integer;
FSystemName: string;
FAutoTLS: Boolean;
FFullSSL: Boolean;
procedure EnhancedCode(const Value: string);
function ReadResult: Integer;
function AuthLogin: Boolean;
function AuthCram: Boolean;
function AuthPlain: Boolean;
function Helo: Boolean;
function Ehlo: Boolean;
function Connect: Boolean;
public
constructor Create;
destructor Destroy; override;
{:Connects to SMTP server (defined in @link(TSynaClient.TargetHost)) and
begin SMTP session. (First try ESMTP EHLO, next old HELO handshake). Parses
ESMTP capabilites and if you specified Username and password and remote
server can handle AUTH command, try login by AUTH command. Preffered login
method is CRAM-MD5 (if safer!). If all OK, result is @true, else result is
@false.}
function Login: Boolean;
{:Close SMTP session (QUIT command) and disconnect from SMTP server.}
function Logout: Boolean;
{:Send RSET SMTP command for reset SMTP session. If all OK, result is @true,
else result is @false.}
function Reset: Boolean;
{:Send NOOP SMTP command for keep SMTP session. If all OK, result is @true,
else result is @false.}
function NoOp: Boolean;
{:Send MAIL FROM SMTP command for set sender e-mail address. If sender's
e-mail address is empty string, transmited message is error message.
If size not 0 and remote server can handle SIZE parameter, append SIZE
parameter to request. If all OK, result is @true, else result is @false.}
function MailFrom(const Value: string; Size: Integer): Boolean;
{:Send RCPT TO SMTP command for set receiver e-mail address. It cannot be an
empty string. If all OK, result is @true, else result is @false.}
function MailTo(const Value: string): Boolean;
{:Send DATA SMTP command and transmit message data. If all OK, result is
@true, else result is @false.}
function MailData(const Value: Tstrings): Boolean;
{:Send ETRN SMTP command for start sending of remote queue for domain in
Value. If all OK, result is @true, else result is @false.}
function Etrn(const Value: string): Boolean;
{:Send VRFY SMTP command for check receiver e-mail address. It cannot be
an empty string. If all OK, result is @true, else result is @false.}
function Verify(const Value: string): Boolean;
{:Call STARTTLS command for upgrade connection to SSL/TLS mode.}
function StartTLS: Boolean;
{:Return string descriptive text for enhanced result codes stored in
@link(EnhCode1), @link(EnhCode2) and @link(EnhCode3).}
function EnhCodeString: string;
{:Try to find specified capability in ESMTP response.}
function FindCap(const Value: string): string;
published
{:result code of last SMTP command.}
property ResultCode: Integer read FResultCode;
{:result string of last SMTP command (begin with string representation of
result code).}
property ResultString: string read FResultString;
{:All result strings of last SMTP command (result is maybe multiline!).}
property FullResult: TStringList read FFullResult;
{:List of ESMTP capabilites of remote ESMTP server. (If you connect to ESMTP
server only!).}
property ESMTPcap: TStringList read FESMTPcap;
{:@TRUE if you successfuly logged to ESMTP server.}
property ESMTP: Boolean read FESMTP;
{:@TRUE if you successfuly pass authorisation to remote server.}
property AuthDone: Boolean read FAuthDone;
{:@TRUE if remote server can handle SIZE parameter.}
property ESMTPSize: Boolean read FESMTPSize;
{:When @link(ESMTPsize) is @TRUE, contains max length of message that remote
server can handle.}
property MaxSize: Integer read FMaxSize;
{:First digit of Enhanced result code. If last operation does not have
enhanced result code, values is 0.}
property EnhCode1: Integer read FEnhCode1;
{:Second digit of Enhanced result code. If last operation does not have
enhanced result code, values is 0.}
property EnhCode2: Integer read FEnhCode2;
{:Third digit of Enhanced result code. If last operation does not have
enhanced result code, values is 0.}
property EnhCode3: Integer read FEnhCode3;
{:name of our system used in HELO and EHLO command. Implicit value is
internet address of your machine.}
property SystemName: string read FSystemName Write FSystemName;
{:If is set to true, then upgrade to SSL/TLS mode if remote server support it.}
property AutoTLS: Boolean read FAutoTLS Write FAutoTLS;
{:SSL/TLS mode is used from first contact to server. Servers with full
SSL/TLS mode usualy using non-standard TCP port!}
property FullSSL: Boolean read FFullSSL Write FFullSSL;
{:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.}
property Sock: TTCPBlockSocket read FSock;
end;
{:A very useful function and example of its use would be found in the TSMTPsend
object. Send maildata (text of e-mail with all SMTP headers! For example when
text of message is created by @link(TMimemess) object) from "MailFrom" e-mail
address to "MailTo" e-mail address (If you need more then one receiver, then
separate their addresses by comma).
Function sends e-mail to a SMTP server defined in "SMTPhost" parameter.
Username and password are used for authorization to the "SMTPhost". If you
don't want authorization, set "Username" and "Password" to empty strings. If
e-mail message is successfully sent, the result returns @true.
If you need use different port number then standard, then add this port number
to SMTPhost after colon. (i.e. '127.0.0.1:1025')}
function SendToRaw(const MailFrom, MailTo, SMTPHost: string;
const MailData: TStrings; const Username, Password: string): Boolean;
{:A very useful function and example of its use would be found in the TSMTPsend
object. Send "Maildata" (text of e-mail without any SMTP headers!) from
"MailFrom" e-mail address to "MailTo" e-mail address with "Subject". (If you
need more then one receiver, then separate their addresses by comma).
This function constructs all needed SMTP headers (with DATE header) and sends
the e-mail to the SMTP server defined in the "SMTPhost" parameter. If the
e-mail message is successfully sent, the result will be @TRUE.
If you need use different port number then standard, then add this port number
to SMTPhost after colon. (i.e. '127.0.0.1:1025')}
function SendTo(const MailFrom, MailTo, Subject, SMTPHost: string;
const MailData: TStrings): Boolean;
{:A very useful function and example of its use would be found in the TSMTPsend
object. Sends "MailData" (text of e-mail without any SMTP headers!) from
"MailFrom" e-mail address to "MailTo" e-mail address (If you need more then one
receiver, then separate their addresses by comma).
This function sends the e-mail to the SMTP server defined in the "SMTPhost"
parameter. Username and password are used for authorization to the "SMTPhost".
If you dont want authorization, set "Username" and "Password" to empty Strings.
If the e-mail message is successfully sent, the result will be @TRUE.
If you need use different port number then standard, then add this port number
to SMTPhost after colon. (i.e. '127.0.0.1:1025')}
function SendToEx(const MailFrom, MailTo, Subject, SMTPHost: string;
const MailData: TStrings; const Username, Password: string): Boolean;
implementation
constructor TSMTPSend.Create;
begin
inherited Create;
FFullResult := TStringList.Create;
FESMTPcap := TStringList.Create;
FSock := TTCPBlockSocket.Create;
FSock.ConvertLineEnd := true;
FTimeout := 60000;
FTargetPort := cSmtpProtocol;
FSystemName := FSock.LocalName;
FAutoTLS := False;
FFullSSL := False;
end;
destructor TSMTPSend.Destroy;
begin
FSock.Free;
FESMTPcap.Free;
FFullResult.Free;
inherited Destroy;
end;
procedure TSMTPSend.EnhancedCode(const Value: string);
var
s, t: string;
e1, e2, e3: Integer;
begin
FEnhCode1 := 0;
FEnhCode2 := 0;
FEnhCode3 := 0;
s := Copy(Value, 5, Length(Value) - 4);
t := Trim(SeparateLeft(s, '.'));
s := Trim(SeparateRight(s, '.'));
if t = '' then
Exit;
if Length(t) > 1 then
Exit;
e1 := StrToIntDef(t, 0);
if e1 = 0 then
Exit;
t := Trim(SeparateLeft(s, '.'));
s := Trim(SeparateRight(s, '.'));
if t = '' then
Exit;
if Length(t) > 3 then
Exit;
e2 := StrToIntDef(t, 0);
t := Trim(SeparateLeft(s, ' '));
if t = '' then
Exit;
if Length(t) > 3 then
Exit;
e3 := StrToIntDef(t, 0);
FEnhCode1 := e1;
FEnhCode2 := e2;
FEnhCode3 := e3;
end;
function TSMTPSend.ReadResult: Integer;
var
s: string;
begin
Result := 0;
FFullResult.Clear;
repeat
s := FSock.RecvString(FTimeout);
FResultString := s;
FFullResult.Add(s);
if FSock.LastError <> 0 then
Break;
until Pos('-', s) <> 4;
s := FFullResult[0];
if Length(s) >= 3 then
Result := StrToIntDef(Copy(s, 1, 3), 0);
FResultCode := Result;
EnhancedCode(s);
end;
function TSMTPSend.AuthLogin: Boolean;
begin
Result := False;
FSock.SendString('AUTH LOGIN' + CRLF);
if ReadResult <> 334 then
Exit;
FSock.SendString(EncodeBase64(FUsername) + CRLF);
if ReadResult <> 334 then
Exit;
FSock.SendString(EncodeBase64(FPassword) + CRLF);
Result := ReadResult = 235;
end;
function TSMTPSend.AuthCram: Boolean;
var
s: ansistring;
begin
Result := False;
FSock.SendString('AUTH CRAM-MD5' + CRLF);
if ReadResult <> 334 then
Exit;
s := Copy(FResultString, 5, Length(FResultString) - 4);
s := DecodeBase64(s);
s := HMAC_MD5(s, FPassword);
s := FUsername + ' ' + StrToHex(s);
FSock.SendString(EncodeBase64(s) + CRLF);
Result := ReadResult = 235;
end;
function TSMTPSend.AuthPlain: Boolean;
var
s: ansistring;
begin
Result := False;
s := ansichar(0) + FUsername + ansichar(0) + FPassword;
FSock.SendString('AUTH PLAIN ' + EncodeBase64(s) + CRLF);
Result := ReadResult = 235;
end;
function TSMTPSend.Connect: Boolean;
begin
FSock.CloseSocket;
FSock.Bind(FIPInterface, cAnyPort);
if FSock.LastError = 0 then
FSock.Connect(FTargetHost, FTargetPort);
if FSock.LastError = 0 then
if FFullSSL then
FSock.SSLDoConnect;
Result := FSock.LastError = 0;
end;
function TSMTPSend.Helo: Boolean;
var
x: Integer;
begin
FSock.SendString('HELO ' + FSystemName + CRLF);
x := ReadResult;
Result := (x >= 250) and (x <= 259);
end;
function TSMTPSend.Ehlo: Boolean;
var
x: Integer;
begin
FSock.SendString('EHLO ' + FSystemName + CRLF);
x := ReadResult;
Result := (x >= 250) and (x <= 259);
end;
function TSMTPSend.Login: Boolean;
var
n: Integer;
auths: string;
s: string;
begin
Result := False;
FESMTP := True;
FAuthDone := False;
FESMTPcap.clear;
FESMTPSize := False;
FMaxSize := 0;
if not Connect then
Exit;
if ReadResult <> 220 then
Exit;
if not Ehlo then
begin
FESMTP := False;
if not Helo then
Exit;
end;
Result := True;
if FESMTP then
begin
for n := 1 to FFullResult.Count - 1 do
FESMTPcap.Add(Copy(FFullResult[n], 5, Length(FFullResult[n]) - 4));
if (not FullSSL) and FAutoTLS and (FindCap('STARTTLS') <> '') then
if StartTLS then
begin
Ehlo;
FESMTPcap.Clear;
for n := 1 to FFullResult.Count - 1 do
FESMTPcap.Add(Copy(FFullResult[n], 5, Length(FFullResult[n]) - 4));
end
else
begin
Result := False;
Exit;
end;
if not ((FUsername = '') and (FPassword = '')) then
begin
s := FindCap('AUTH ');
if s = '' then
s := FindCap('AUTH=');
auths := UpperCase(s);
if s <> '' then
begin
if Pos('CRAM-MD5', auths) > 0 then
FAuthDone := AuthCram;
if (not FauthDone) and (Pos('PLAIN', auths) > 0) then
FAuthDone := AuthPlain;
if (not FauthDone) and (Pos('LOGIN', auths) > 0) then
FAuthDone := AuthLogin;
end;
end;
s := FindCap('SIZE');
if s <> '' then
begin
FESMTPsize := True;
FMaxSize := StrToIntDef(Copy(s, 6, Length(s) - 5), 0);
end;
end;
end;
function TSMTPSend.Logout: Boolean;
begin
FSock.SendString('QUIT' + CRLF);
Result := ReadResult = 221;
FSock.CloseSocket;
end;
function TSMTPSend.Reset: Boolean;
begin
FSock.SendString('RSET' + CRLF);
Result := ReadResult div 100 = 2;
end;
function TSMTPSend.NoOp: Boolean;
begin
FSock.SendString('NOOP' + CRLF);
Result := ReadResult div 100 = 2;
end;
function TSMTPSend.MailFrom(const Value: string; Size: Integer): Boolean;
var
s: string;
begin
s := 'MAIL FROM:<' + Value + '>';
if FESMTPsize and (Size > 0) then
s := s + ' SIZE=' + IntToStr(Size);
FSock.SendString(s + CRLF);
Result := ReadResult div 100 = 2;
end;
function TSMTPSend.MailTo(const Value: string): Boolean;
begin
FSock.SendString('RCPT TO:<' + Value + '>' + CRLF);
Result := ReadResult div 100 = 2;
end;
function TSMTPSend.MailData(const Value: TStrings): Boolean;
var
n: Integer;
s: string;
t: string;
x: integer;
begin
Result := False;
FSock.SendString('DATA' + CRLF);
if ReadResult <> 354 then
Exit;
t := '';
x := 1500;
for n := 0 to Value.Count - 1 do
begin
s := Value[n];
if Length(s) >= 1 then
if s[1] = '.' then
s := '.' + s;
if Length(t) + Length(s) >= x then
begin
FSock.SendString(t);
t := '';
end;
t := t + s + CRLF;
end;
if t <> '' then
FSock.SendString(t);
FSock.SendString('.' + CRLF);
Result := ReadResult div 100 = 2;
end;
function TSMTPSend.Etrn(const Value: string): Boolean;
var
x: Integer;
begin
FSock.SendString('ETRN ' + Value + CRLF);
x := ReadResult;
Result := (x >= 250) and (x <= 259);
end;
function TSMTPSend.Verify(const Value: string): Boolean;
var
x: Integer;
begin
FSock.SendString('VRFY ' + Value + CRLF);
x := ReadResult;
Result := (x >= 250) and (x <= 259);
end;
function TSMTPSend.StartTLS: Boolean;
begin
Result := False;
if FindCap('STARTTLS') <> '' then
begin
FSock.SendString('STARTTLS' + CRLF);
if (ReadResult = 220) and (FSock.LastError = 0) then
begin
Fsock.SSLDoConnect;
Result := FSock.LastError = 0;
end;
end;
end;
function TSMTPSend.EnhCodeString: string;
var
s, t: string;
begin
s := IntToStr(FEnhCode2) + '.' + IntToStr(FEnhCode3);
t := '';
if s = '0.0' then t := 'Other undefined Status';
if s = '1.0' then t := 'Other address status';
if s = '1.1' then t := 'Bad destination mailbox address';
if s = '1.2' then t := 'Bad destination system address';
if s = '1.3' then t := 'Bad destination mailbox address syntax';
if s = '1.4' then t := 'Destination mailbox address ambiguous';
if s = '1.5' then t := 'Destination mailbox address valid';
if s = '1.6' then t := 'Mailbox has moved';
if s = '1.7' then t := 'Bad sender''s mailbox address syntax';
if s = '1.8' then t := 'Bad sender''s system address';
if s = '2.0' then t := 'Other or undefined mailbox status';
if s = '2.1' then t := 'Mailbox disabled, not accepting messages';
if s = '2.2' then t := 'Mailbox full';
if s = '2.3' then t := 'Message Length exceeds administrative limit';
if s = '2.4' then t := 'Mailing list expansion problem';
if s = '3.0' then t := 'Other or undefined mail system status';
if s = '3.1' then t := 'Mail system full';
if s = '3.2' then t := 'System not accepting network messages';
if s = '3.3' then t := 'System not capable of selected features';
if s = '3.4' then t := 'Message too big for system';
if s = '3.5' then t := 'System incorrectly configured';
if s = '4.0' then t := 'Other or undefined network or routing status';
if s = '4.1' then t := 'No answer from host';
if s = '4.2' then t := 'Bad connection';
if s = '4.3' then t := 'Routing server failure';
if s = '4.4' then t := 'Unable to route';
if s = '4.5' then t := 'Network congestion';
if s = '4.6' then t := 'Routing loop detected';
if s = '4.7' then t := 'Delivery time expired';
if s = '5.0' then t := 'Other or undefined protocol status';
if s = '5.1' then t := 'Invalid command';
if s = '5.2' then t := 'Syntax error';
if s = '5.3' then t := 'Too many recipients';
if s = '5.4' then t := 'Invalid command arguments';
if s = '5.5' then t := 'Wrong protocol version';
if s = '6.0' then t := 'Other or undefined media error';
if s = '6.1' then t := 'Media not supported';
if s = '6.2' then t := 'Conversion required and prohibited';
if s = '6.3' then t := 'Conversion required but not supported';
if s = '6.4' then t := 'Conversion with loss performed';
if s = '6.5' then t := 'Conversion failed';
if s = '7.0' then t := 'Other or undefined security status';
if s = '7.1' then t := 'Delivery not authorized, message refused';
if s = '7.2' then t := 'Mailing list expansion prohibited';
if s = '7.3' then t := 'Security conversion required but not possible';
if s = '7.4' then t := 'Security features not supported';
if s = '7.5' then t := 'Cryptographic failure';
if s = '7.6' then t := 'Cryptographic algorithm not supported';
if s = '7.7' then t := 'Message integrity failure';
s := '???-';
if FEnhCode1 = 2 then s := 'Success-';
if FEnhCode1 = 4 then s := 'Persistent Transient Failure-';
if FEnhCode1 = 5 then s := 'Permanent Failure-';
Result := s + t;
end;
function TSMTPSend.FindCap(const Value: string): string;
var
n: Integer;
s: string;
begin
s := UpperCase(Value);
Result := '';
for n := 0 to FESMTPcap.Count - 1 do
if Pos(s, UpperCase(FESMTPcap[n])) = 1 then
begin
Result := FESMTPcap[n];
Break;
end;
end;
{==============================================================================}
function SendToRaw(const MailFrom, MailTo, SMTPHost: string;
const MailData: TStrings; const Username, Password: string): Boolean;
var
SMTP: TSMTPSend;
s, t: string;
begin
Result := False;
SMTP := TSMTPSend.Create;
try
// if you need SOCKS5 support, uncomment next lines:
// SMTP.Sock.SocksIP := '127.0.0.1';
// SMTP.Sock.SocksPort := '1080';
// if you need support for upgrade session to TSL/SSL, uncomment next lines:
// SMTP.AutoTLS := True;
// if you need support for TSL/SSL tunnel, uncomment next lines:
// SMTP.FullSSL := True;
SMTP.TargetHost := Trim(SeparateLeft(SMTPHost, ':'));
s := Trim(SeparateRight(SMTPHost, ':'));
if (s <> '') and (s <> SMTPHost) then
SMTP.TargetPort := s;
SMTP.Username := Username;
SMTP.Password := Password;
if SMTP.Login then
begin
if SMTP.MailFrom(GetEmailAddr(MailFrom), Length(MailData.Text)) then
begin
s := MailTo;
repeat
t := GetEmailAddr(Trim(FetchEx(s, ',', '"')));
if t <> '' then
Result := SMTP.MailTo(t);
if not Result then
Break;
until s = '';
if Result then
Result := SMTP.MailData(MailData);
end;
SMTP.Logout;
end;
finally
SMTP.Free;
end;
end;
function SendToEx(const MailFrom, MailTo, Subject, SMTPHost: string;
const MailData: TStrings; const Username, Password: string): Boolean;
var
t: TStrings;
begin
t := TStringList.Create;
try
t.Assign(MailData);
t.Insert(0, '');
t.Insert(0, 'X-mailer: Synapse - Delphi & Kylix TCP/IP library by Lukas Gebauer');
t.Insert(0, 'Subject: ' + Subject);
t.Insert(0, 'Date: ' + Rfc822DateTime(now));
t.Insert(0, 'To: ' + MailTo);
t.Insert(0, 'From: ' + MailFrom);
Result := SendToRaw(MailFrom, MailTo, SMTPHost, t, Username, Password);
finally
t.Free;
end;
end;
function SendTo(const MailFrom, MailTo, Subject, SMTPHost: string;
const MailData: TStrings): Boolean;
begin
Result := SendToEx(MailFrom, MailTo, Subject, SMTPHost, MailData, '', '');
end;
end.
Reference in New Issue View Git Blame Copy Permalink