idsmtprelay.pas

photo.163.com 相册下载器 多线程下载

{ $HDR$}
{**********************************************************************}
{ Unit archived using Team Coherence                                   }
{ Team Coherence is Copyright 2002 by Quality Software Components      }
{                                                                      }
{ For further information / comments, visit our WEB site at            }
{ http://www.TeamCoherence.com                                         }
{**********************************************************************}
{}
{ $Log:  20462: IdSMTPRelay.pas
{
{   Rev 1.7    10/26/2004 10:55:34 PM  JPMugaas
{ Updated refs.
}
{
{   Rev 1.6    2004.03.06 1:31:52 PM  czhower
{ To match Disconnect changes to core.
}
{
{   Rev 1.5    2004.02.07 4:57:20 PM  czhower
{ Fixed warning.
}
{
{   Rev 1.4    2004.02.03 5:45:48 PM  czhower
{ Name changes
}
{
{   Rev 1.3    1/21/2004 4:03:26 PM  JPMugaas
{ InitComponent
}
{
    Rev 1.2    11/4/2003 10:22:56 PM  DSiders
  Use IdException for exceptions moved to the unit.
}
{
{   Rev 1.1    2003.10.18 9:42:14 PM  czhower
{ Boatload of bug fixes to command handlers.
}
{
{   Rev 1.0    6/15/2003 03:27:18 PM  JPMugaas
{ Renamed IdDirect SMTP to IdSMTPRelay.
}
{
{   Rev 1.15    6/15/2003 01:09:30 PM  JPMugaas
{ Now uses new base class in TIdSMTPBase.  I removed the old original
{ unoptimized code that made a connection for each recipient for better
{ maintenance and because I doubt anyone would use that anyway.
}
{
{   Rev 1.14    6/5/2003 04:54:16 AM  JPMugaas
{ Reworkings and minor changes for new Reply exception framework.
}
{
{   Rev 1.13    5/26/2003 12:21:50 PM  JPMugaas
}
{
{   Rev 1.12    5/25/2003 03:54:12 AM  JPMugaas
}
{
{   Rev 1.11    5/25/2003 01:41:08 AM  JPMugaas
{ Sended changed to Sent.  TryImplicitTLS now will only be true if
{ UseSSL<>NoSSL.  UseEHLO=False will now disable TLS usage and TLS usage being
{ set causes UseEHLO to be true.  StatusItem collection Items now have default
{ values for Sent and ReplyCode.
}
{
{   Rev 1.10    5/25/2003 12:40:34 AM  JPMugaas
{ Published events from TIdExplicitTLSClient to be consistant with other
{ components in Indy and for any custom handling of certain TLS negotiatiation
{ problems.
}
{
{   Rev 1.9    5/25/2003 12:17:16 AM  JPMugaas
{ Now can support SSL (either requiring SSL or using it if available).  This is
{ in addition, it can optionally support ImplicitTLS (note that I do not
{ recommend this because that is depreciated -and the port for it was
{ deallocated and this does incur a performance penalty with an additional
{ connect attempt - and possibly a timeout in some firewall situations).
}
{
    Rev 1.8    5/23/2003 7:48:12 PM  BGooijen
  TIdSMTPRelayStatusItem.FEnhancedCode object was not created
}
{
{   Rev 1.7    5/23/2003 05:02:42 AM  JPMugaas
}
{
{   Rev 1.6    5/23/2003 04:52:22 AM  JPMugaas
{ Work started on TIdSMTPRelay to support enhanced error codes.
}
{
{   Rev 1.5    5/18/2003 02:31:50 PM  JPMugaas
{ Reworked some things so IdSMTP and IdDirectSMTP can share code including
{ stuff for pipelining.
}
{
{   Rev 1.4    4/28/2003 03:36:22 PM  JPMugaas
{ Revered back to the version I checked in earlier because of my API changes to
{ the DNS classes.
}
{
{   Rev 1.2    4/28/2003 07:00:02 AM  JPMugaas
{ Should now compile.
}
{
{   Rev 1.1    12/6/2002 02:35:22 PM  JPMugaas
{ Now compiles with Indy 10.
}
{
{   Rev 1.0    11/14/2002 02:17:28 PM  JPMugaas
}
unit IdSMTPRelay;

{
	Original Author: Maximiliano Di Rienzo
   [e-mail]
   Variation of the TIdSMTP that connects directly with the recipient's SMTP server
   and delivers the message, it doesn't use a relay SMTP server to deliver the message.

   Hides the procs Connect and Disconnect (protected now) because these are called internally
   to connect to the dynamically resolved host based on the MX server of the recipient's domain.
   The procs related to the auth schema have been removed because they aren't needed.

   Introduces the property
    	property StatusList:TIdSMTPRelayStatusList;
   it's a collection containing the status of each recipient's address after the Send method is called

   and the event
    	property OnDirectSMTPStatus:TIdSMTPRelayStatus;
	to keep track of the status as the sending is in progress.
}

interface

uses
  Classes, IdAssignedNumbers, IdException, IdExceptionCore,
  IdEMailAddress, IdGlobal, IdHeaderList,
  IdDNSResolver, IdMessage, IdMessageClient,
  IdSMTPBase, IdReplySMTP, IdTStrings, SysUtils;

const
  DEF_OneConnectionPerDomain = True;

type
  TIdSMTPRelayStatusAction = (dmResolveMS, dmConecting, dmConected, dmSending, dmWorkBegin, dmWorkEndOK, dmWorkEndWithException);
  TIdSMTPRelayStatus = procedure(Sender:TObject; AEMailAddress:TIdEmailAddressItem; Action:TIdSMTPRelayStatusAction) of Object;

  EIdDirectSMTPCannotAssingHost = class(EIdException);
  EIdDirectSMTPCannotResolveMX = class(EIdException);

  TIdSSLSupport = (NoSSL, SupportSSL, RequireSSL);

const
  DEF_SSL_SUPPORT = NoSSL;
  DEF_TRY_IMPLICITTLS = False;
  DEF_REPLY_CODE = 0;
  DEF_SENT = False;
type
  TIdSMTPRelayStatusItem = class(TCollectionItem)
  protected
    FSent: Boolean;
    FExceptionMessage: String;
    FEmailAddress: String;
    FReplyCode : Integer;
    FEnhancedCode : TIdSMTPEnhancedCode;
    procedure SetSent(const Value: Boolean);
    procedure SetExceptionMessage(const Value: String);
    procedure SetEmailAddress(const Value: String);
    procedure SetEnhancedCode(const Value: TIdSMTPEnhancedCode);
    procedure SetReplyCode(const Value: Integer);
  public
    constructor Create(Collection: TCollection); override;
    destructor Destroy; override;
  published
    property EmailAddress: String read FEmailAddress write SetEmailAddress;
    property ExceptionMessage:String read FExceptionMessage write SetExceptionMessage;
    property Sent:Boolean read FSent write SetSent default DEF_SENT;
    property ReplyCode : Integer read FReplyCode write SetReplyCode default DEF_REPLY_CODE;
    property EnhancedCode : TIdSMTPEnhancedCode read FEnhancedCode write SetEnhancedCode;
  end;

  TIdSMTPRelayStatusList = class(TOwnedCollection)
  protected
    function GetItems(Index: Integer): TIdSMTPRelayStatusItem;
    procedure SetItems(Index: Integer;const Value: TIdSMTPRelayStatusItem);
  public
    function Add : TIdSMTPRelayStatusItem;
    property Items[Index: Integer]: TIdSMTPRelayStatusItem read GetItems write SetItems; default;
  end;
  TIdSMTPRelay = class;
  TIdSSLSupportOptions = class(TPersistent)
  protected
    FSSLSupport : TIdSSLSupport;
    FTryImplicitTLS : Boolean;
    FOwner : TIdSMTPRelay;

    procedure SetSSLSupport(const Value: TIdSSLSupport);
    procedure SetTryImplicitTLS(const Value: Boolean);
  public
    constructor Create(AOwner : TIdSMTPRelay);
    procedure Assign(Source: TPersistent); override;
  published
    property SSLSupport : TIdSSLSupport read FSSLSupport write SetSSLSupport default DEF_SSL_SUPPORT;
    property TryImplicitTLS : Boolean read FTryImplicitTLS write SetTryImplicitTLS default DEF_TRY_IMPLICITTLS;
  end;
  TIdSMTPRelay = class(TIdSMTPBase)
  protected
    FMXServerList:TIdStringList;
    FStatusList:TIdSMTPRelayStatusList;
    FDNSServer: String;
    FOnDirectSMTPStatus: TIdSMTPRelayStatus;
    FMailAgent: string;
    FHeloName : String;
    FPipeline : Boolean;
    FUseEHLO : Boolean;
    FSSLOptions : TIdSSLSupportOptions;
    procedure Connect(AEMailAddress : TIdEMailAddressItem); reintroduce;
    procedure ResolveMXServers(AAddress:String);
    procedure SetDNSServer(const Value: String);
    procedure SetOnStatus(const Value: TIdSMTPRelayStatus);
    procedure SetUseEhlo(const AValue : Boolean); override;
    procedure SetHost(const Value: String); override;
    function GetSupportsTLS : boolean; override;
    procedure ProcessException(AException: Exception; AEMailAddress : TIdEMailAddressItem);
    procedure SetSSLOptions(const Value: TIdSSLSupportOptions);
    //
    procedure InitComponent; override;
  public
    procedure Assign(Source: TPersistent); override;
    destructor Destroy; override;
    procedure DisconnectNotifyPeer; override;
    procedure Send (AMsg: TIdMessage); override;
  published
    property DNSServer:String read FDNSServer write SetDNSServer;
    property OnDirectSMTPStatus:TIdSMTPRelayStatus read FOnDirectSMTPStatus write SetOnStatus;
    property StatusList:TIdSMTPRelayStatusList read FStatusList;
    property SSLOptions : TIdSSLSupportOptions read FSSLOptions write SetSSLOptions;
    property OnTLSHandShakeFailed;
    property OnTLSNotAvailable;
    property OnTLSNegCmdFailed;

  end;

implementation

uses
  IdGlobalProtocols, IdStack, IdCoderMIME, IdDNSCommon,
  IdResourceStringsProtocols, IdExplicitTLSClientServerBase,
  IdSSL,
  IdStackConsts,
  IdTCPClient,
  IdTCPConnection;

{ TIdSMTPRelay }

procedure TIdSMTPRelay.Assign(Source: TPersistent);
begin
  if Source is TIdSMTPRelay then begin
    MailAgent := TIdSMTPRelay(Source).MailAgent;
    Port := TIdSMTPRelay(Source).Port;
    DNSServer:=TIdSMTPRelay(Source).DNSServer;
  end else begin
    inherited;
  end;
end;

procedure TIdSMTPRelay.Connect(AEMailAddress : TIdEMailAddressItem);
var LCanImplicitTLS : Boolean;
//const
//   AcceptableErrors : array of Cardinal = [Id_WSAETIMEDOUT, Id_WSAECONNREFUSED];
begin
  LCanImplicitTLS := Self.FSSLOptions.TryImplicitTLS;
  if LCanImplicitTLS then
  begin
    try
      UseTLS := utUseImplicitTLS;
      inherited Connect;
    except
      on E: EIdSocketError do begin
       // If 10061 - connection refused - retry without ImplicitTLS
       // If 10060 - connection timed out - retry without ImplicitTLS
        if (E.LastError=Id_WSAECONNREFUSED) or
          (E.LastError=Id_WSAETIMEDOUT) then begin
          LCanImplicitTLS := False;
        end
        else
        begin
          raise;
        end;
      end;
    end;
  end;
  if LCanImplicitTLS=False then
  begin
    case Self.FSSLOptions.FSSLSupport of
     SupportSSL : FUseTLS := utUseExplicitTLS;
     RequireSSL : FUseTLS := utUseRequireTLS;
    else
      FUseTLS := utNoTLSSupport;
    end;
    inherited Connect;
  end;
  try
    GetResponse([220]);
    SendGreeting;
    StartTLS;
  except
    on E : Exception do
    begin
      ProcessException(E,AEMailAddress);
      Disconnect;
      raise;
    end;
  end;
end;

procedure TIdSMTPRelay.InitComponent;
begin
  inherited;
  FSSLOptions := TIdSSLSupportOptions.Create(Self);
  FMXServerList:=TIdStringList.Create;
  FStatusList:=TIdSMTPRelayStatusList.Create(Self,TIdSMTPRelayStatusItem);
end;

destructor TIdSMTPRelay.Destroy;
begin
  FreeAndNil(FSSLOptions);
  FreeAndNil(FMXServerList);
  FreeAndNil(FStatusList);
  inherited;
end;

procedure TIdSMTPRelay.DisconnectNotifyPeer;
begin
  inherited;