{ $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:  11747: IdSMTP.pas
{
{   Rev 1.30    24/10/2003 20:53:02  CCostelloe
{ Bug fix of LRecipients.EMailAddresses in Send.
}
{
{   Rev 1.29    2003.10.17 6:15:16 PM  czhower
{ Bug fix with quit.
}
{
    Rev 1.28    10/17/2003 1:01:04 AM  DSiders
  Added localization comments.
}
{
{   Rev 1.27    2003.10.14 1:28:04 PM  czhower
{ DotNet
}
{
{   Rev 1.26    10/11/2003 7:14:36 PM  BGooijen
{ Changed IdCompilerDefines.inc path
}
{
{   Rev 1.25    10/10/2003 10:45:10 PM  BGooijen
{ DotNet
}
{
{   Rev 1.24    2003.10.02 9:27:52 PM  czhower
{ DotNet Excludes
}
{
{   Rev 1.23    6/15/2003 03:28:30 PM  JPMugaas
{ Minor class change.
}
{
{   Rev 1.22    6/15/2003 01:13:40 PM  JPMugaas
{ Now uses new base class.
}
{
{   Rev 1.21    6/5/2003 04:54:08 AM  JPMugaas
{ Reworkings and minor changes for new Reply exception framework.
}
{
{   Rev 1.20    6/4/2003 04:10:40 PM  JPMugaas
{ Removed hacked GetInternelResponse.
{
{ Updated to use Kudzu's new string reply code.
}
{
{   Rev 1.19    5/26/2003 12:24:04 PM  JPMugaas
}
{
{   Rev 1.18    5/25/2003 03:54:48 AM  JPMugaas
}
{
{   Rev 1.17    5/25/2003 12:13:22 AM  JPMugaas
{ SMTP StartTLS code moved into IdSMTPCommon for sharing with TIdDirectSMTP.
{ StartTLS is now called in Authenticate to prevent unintentional unencrypted
{ password transmission (e.g. AUTH LOGIN being called before STARTTLS).
}
{
{   Rev 1.16    5/23/2003 04:52:26 AM  JPMugaas
{ Work started on TIdDirectSMTP to support enhanced error codes.
}
{
{   Rev 1.15    5/22/2003 05:26:16 PM  JPMugaas
{ RFC 2034
}
{
{   Rev 1.14    5/18/2003 02:31:42 PM  JPMugaas
{ Reworked some things so IdSMTP and IdDirectSMTP can share code including
{ stuff for pipelining.
}
{
{   Rev 1.13    5/15/2003 11:09:46 AM  JPMugaas
{ "RFC 2197 SMTP  Service Extension for Command Pipelining" now supported.  It
{ should increase efficiency in TIdSMTP.
}
{
{   Rev 1.12    5/13/2003 07:35:06 AM  JPMugaas
{ Made UseEHLO a requirement for explicit TLS because explicit TLS using EHLO
{ to determine if the server supports explicit TLS. Setting UseEHLO will the
{ UseTLS property be the default (no encryption) and setting UseTLS to an
{ explicit TLS setting will cause the UseEHLO property to be true.
}
{
{   Rev 1.11    5/13/2003 07:03:48 AM  JPMugaas
{ Ciaran Costelloe reported a bug in the Assign method.  Username and Password
{ were still being assigned even though the SMTP component does not publish or
{ use them.  I have updated the SMTP assign method with the new properties and
{ removed the references to Password and Username.
}
{
{   Rev 1.10    5/10/2003 10:10:40 PM  JPMugaas
{ Bug fixes.
}
{
{   Rev 1.9    5/8/2003 08:44:22 PM  JPMugaas
{ Moved some SASL authentication code down to an anscestor for reuse.  WIll
{ clean up soon.
}
{
{   Rev 1.8    5/8/2003 03:18:30 PM  JPMugaas
{ Flattened ou the SASL authentication API, made a custom descendant of SASL
{ enabled TIdMessageClient classes.
}
{
{   Rev 1.7    5/8/2003 11:28:14 AM  JPMugaas
{ Moved feature negoation properties down to the ExplicitTLSClient level as
{ feature negotiation goes hand in hand with explicit TLS support.
}
{
{   Rev 1.6    5/8/2003 02:18:18 AM  JPMugaas
{ Fixed an AV in IdPOP3 with SASL list on forms.  Made exceptions for SASL
{ mechanisms missing more consistant, made IdPOP3 support feature feature
{ negotiation, and consolidated some duplicate code.
}
{
{   Rev 1.5    4/5/2003 02:06:32 PM  JPMugaas
{ TLS handshake itself can now be handled.
}
{
{   Rev 1.4    3/27/2003 05:46:50 AM  JPMugaas
{ Updated framework with an event if the TLS negotiation command fails.
{ Cleaned up some duplicate code in the clients.
}
{
{   Rev 1.3    3/26/2003 04:19:34 PM  JPMugaas
{ Cleaned-up some code and illiminated some duplicate things.
}
{
{   Rev 1.2    3/13/2003 09:49:32 AM  JPMugaas
{ Now uses an abstract SSL base class instead of OpenSSL so 3rd-party vendors
{ can plug-in their products.
}
{
{   Rev 1.1    12/15/2002 05:50:18 PM  JPMugaas
{ SMTP and IMAP4 compile.  IdPOP3, IdFTP, IMAP4, and IdSMTP now restored in
{ IdRegister.
}
{
{   Rev 1.0    11/13/2002 08:00:48 AM  JPMugaas
}
unit IdSMTP;

{$I Core\IdCompilerDefines.inc}

interface

uses
  Classes,
  IdAssignedNumbers,
  IdEMailAddress,
  IdException,
  {$IFNDEF DotNetExclude}
  IdExplicitTLSClientServerBase,
  IdSASL,
  IdSASLList,
  {$ENDIF}
  IdHeaderList,
  IdMessage,
  IdMessageClient,
  IdSMTPBase;

const
  DEF_SMTP_Use_ImplicitTLS = False;
  DEF_SMTP_PIPELINE = True;

type
  TIdSMTPAuthenticationType = (atNone, atSASL);
const
 DEF_SMTP_AUTH = atNone;
type
  TIdSMTP = class(TIdSMTPBase)
  protected
    {$IFNDEF DotNetExclude}
    {This is just an internal flag we use to determine if we already
     authenticated to the server }
    FDidAuthenticate : Boolean;
    FAuthType : TIdSMTPAuthenticationType;
    FSASLMechanisms : TIdSASLList;
    procedure SetAuthType(const Value: TIdSMTPAuthenticationType);
    procedure SetUseEhlo(const Value: Boolean); override;
    procedure SetUseTLS(AValue: TIdUseTLS); override;
    procedure SetPipeline(const AValue: Boolean);
    function GetSASLMechanisms: TIdSASLList;
    {$ENDIF}
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
  public
    procedure Assign(Source: TPersistent); override;
    {$IFNDEF DotNetExclude}
    function Authenticate : Boolean; virtual;
    {$ENDIF}
    procedure Connect; override;
    constructor Create( AOwner : TComponent ); override;
    destructor Destroy; override;
    procedure Disconnect; override;
    class procedure QuickSend ( const AHost, ASubject, ATo,
      AFrom, AText : String);
    procedure Send (AMsg: TIdMessage); override;
    procedure Expand( AUserName : String; AResults : TStrings); virtual;
    function Verify( AUserName : String) : String; virtual;
    //
  published
    property Host;
    property Port default IdPORT_SMTP;
    {$IFNDEF DotNetExclude}
    property AuthType : TIdSMTPAuthenticationType read FAuthType write FAuthType default DEF_SMTP_AUTH;
    property SASLMechanisms: TIdSASLList read FSASLMechanisms write FSASLMechanisms;
    property UseTLS;
    property OnTLSNotAvailable;
    {$ENDIF}
  end;


implementation

uses
  IdCoderMIME,
  IdCoreGlobal,
  IdGlobal,
  IdReplySMTP,
  {$IFNDEF DotNetExclude}
  IdSSL,
  {$ENDIF}
  IdResourceStrings,
  SysUtils, IdTCPConnection, Math;

{ TIdSMTP }

procedure TIdSMTP.Assign(Source: TPersistent);
var LS : TIdSMTP;
begin
  if Source is TIdSMTP then begin
    LS := Source as TIdSMTP;
    //properties
                                                                
    //I Wonder because it might be created explcitly at run-time.
    {$IFNDEF DotNetExclude}
    AuthType := LS.AuthType;
    HeloName := LS.HeloName;
    SASLMechanisms := LS.SASLMechanisms;
    UseEhlo := LS.UseEhlo;
    UseTLS := LS.UseTLS;
    {$ENDIF}
    Host := LS.Host;
    MailAgent := LS.MailAgent;
    Port := LS.Port;
    Tag := LS.Tag;
    //events
    {$IFNDEF DotNetExclude}
    OnTLSNotAvailable := LS.OnTLSNotAvailable;
    OnTLSHandShakeFailed := LS.OnTLSHandShakeFailed;
    OnTLSNegCmdFailed := LS.OnTLSNegCmdFailed;
    {$ENDIF}

    OnConnected := LS.OnConnected;
    OnDisconnected := LS.OnDisconnected;
    OnWork := LS.OnWork;
    OnWorkBegin := LS.OnWorkBegin;
    OnWorkEnd := LS.OnWorkEnd;
    OnStatus := LS.OnStatus;
  end else begin
    inherited;
  end;
end;
{$IFNDEF DotNetExclude}
function TIdSMTP.Authenticate : Boolean;
begin
  //This will look strange but we have logic in that method to make
  //sure that the STARTTLS command is used appropriately.
  //Note we put this in Authenticate only to ensure that TLS negotiation
  //is done before a password is sent over a network unencrypted.
  StartTLS;
  if (AuthType = atSASL) and ((SASLMechanisms=nil) or (SASLMechanisms.Count = 0)) then begin
    raise EIdSASLMechNeeded.Create(RSASLRequired);
  end;
  if FAuthType = atSASL then begin
  //note that we pass the numbers as strings here so the SASL stuff can work
  //with IMAP4 and POP3 where non-numeric strings are used for reply codes
    SASLMechanisms.LoginSASL('AUTH', ['235'], ['334'], Self, Capabilities); {do not localize}
  end;
  //do nothing for atNone
  FDidAuthenticate := True;
  Result := FDidAuthenticate;
end;
{$ENDIF}

procedure TIdSMTP.Connect;
begin
  inherited Connect;
  try
    GetResponse(220);
    SendGreeting;
  except
    Disconnect;
    Raise;
  end;
end;

constructor TIdSMTP.Create(AOwner: TComponent);
begin
  inherited;
  {$IFNDEF DotNetExclude}
  FUseEhlo:=IdDEF_UseEhlo;
  FImplicitTLSProtPort := IdPORT_ssmtp;
  FRegularProtPort := IdPORT_SMTP;
  FAuthType:=DEF_SMTP_AUTH;
  FPipeLine := DEF_SMTP_PIPELINE;
 // FImplicitTLS := DEF_SMTP_Use_ImplicitTLS;
  {$ENDIF}
  Port := IdPORT_SMTP;
end;

destructor TIdSMTP.Destroy;
begin
  inherited;
end;

procedure TIdSMTP.Disconnect;
begin
  try
    if Connected then  begin
      SendCmd('QUIT', 221);    {Do not Localize}
    end;
  finally
    inherited;
    {$IFNDEF DotNetExclude}
    FDidAuthenticate := False;
    {$ENDIF}
  end;
end;

procedure TIdSMTP.Expand(AUserName: String; AResults: TStrings);
begin
  SendCMD('EXPN ' + AUserName, [250, 251]);    {Do not Localize}
end;

class procedure TIdSMTP.QuickSend (const AHost, ASubject, ATo, AFrom, AText : String);
var
  LSMTP: TIdSMTP;
  LMsg: TIdMessage;
begin
  LSMTP := TIdSMTP.Create(nil);
  try
    LMsg := TIdMessage.Create(LSMTP);
    try
      with LMsg do
      begin
        Subject := ASubject;
        Recipients.EMailAddresses := ATo;
        From.Text := AFrom;
        Body.Text := AText;
      end;
      with LSMTP do
      begin
        Host := AHost;
        Connect; try;
          Send(LMsg);
        finally Disconnect; end;
      end;
    finally
      FreeAndNil(LMsg);
    end;
  finally
    FreeAndNil(LSMTP);
  end;
end;

procedure TIdSMTP.Send(AMsg: TIdMessage);
var LRecipients : TIdEMailAddressList;
begin
  {$IFNDEF DotNetExclude}
  if FAuthType <> atNone then begin
  //Authenticate now calls StartTLS
  //so that you do not send login information before TLS negotiation (big oops security wise).
    Authenticate;
  end
  else
  begin
    //This will look strange but we have logic in that method to make
    //sure that the STARTTLS command is used appropriately.
    //Note that Authenticate now calls StartTLS.
    StartTLS;
  end;
  {$ENDIF}
  AMsg.ExtraHeaders.Values[XMAILER_HEADER] := MailAgent;
  LRecipients := TIdEMailAddressList.Create(nil);
  try
    LRecipients.EMailAddresses := AMsg.Recipients.EMailAddresses;
    if AMsg.CCList.Count > 0 then begin
        LRecipients.EMailAddresses := LRecipients.EMailAddresses + ', ' + AMsg.CCList.EMailAddresses;
    end;
    if AMsg.BccList.Count > 0 then begin
        LRecipients.EMailAddresses := LRecipients.EMailAddresses + ', ' + AMsg.BccList.EMailAddresses;
    end;
    InternalSend(AMsg, LRecipients);
  finally
    FreeAndNil(LRecipients);
  end;
end;

{$IFNDEF DotNetExclude}
procedure TIdSMTP.SetAuthType(const Value: TIdSMTPAuthenticationType);
Begin
  inherited;
  if Value = atSASL then
  begin
    FUseEhlo:=TRUE;
  end;
end;
{$ENDIF}

{$IFNDEF DotNetExclude}
procedure TIdSMTP.SetUseEhlo(const Value: Boolean);
Begin
  FUseEhlo:= Value;
  if NOT Value then
  begin
    FAuthType:=atNone;
    if FUseTLS in ExplicitTLSVals then
    begin
      FUseTLS := DEF_USETLS;
      FPipeLine := False;
    end;
  end;
End;
{$ENDIF}

function TIdSMTP.Verify(AUserName: string): string;
begin
  SendCMD('VRFY ' + AUserName, [250, 251]);    {Do not Localize}
  Result := LastCmdResult.Text[0];
end;

{$IFNDEF DotNetExclude}
function TIdSMTP.GetSASLMechanisms: TIdSASLList;
begin
  Result := FSASLMechanisms;
end;
{$ENDIF}

procedure TIdSMTP.Notification(AComponent: TComponent;
  Operation: TOperation);
begin
  {$IFNDEF DotNetExclude}
  if (Operation = opRemove) then begin
    if AComponent = FSASLMechanisms then begin
      FSASLMechanisms := nil;
    end;
  end;
  {$ENDIF}
  inherited;
end;

{$IFNDEF DotNetExclude}
procedure TIdSMTP.SetUseTLS(AValue: TIdUseTLS);
begin
  inherited;
  if FUseTLS in ExplicitTLSVals then
  begin
    UseEhlo := True;
  end;
end;
{$ENDIF}

{$IFNDEF DotNetExclude}
procedure TIdSMTP.SetPipeline(const AValue: Boolean);
begin
  FPipeLine := AValue;
  if AValue then
  begin
    FUseEhlo := True;
  end;
end;
{$ENDIF}

end.


