idsmtpserver.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:  107843: IdSMTPServer.pas
{
{   Rev 1.8    24/10/2004 21:26:14  ANeillans
{ RCPTList can be set
}
{
    Rev 1.7    9/15/2004 5:02:06 PM  DSiders
  Added localization comments.
}
{
{   Rev 1.6    31/08/2004 20:21:34  ANeillans
{ Bug fix -- format problem.
}
{
{   Rev 1.5    08/08/2004 21:03:10  ANeillans
{ Continuing....
}
{
{   Rev 1.4    02/08/2004 21:14:28  ANeillans
{ Auth working
}
{
{   Rev 1.3    01/08/2004 13:02:16  ANeillans
{ Development.
}
{
{   Rev 1.2    01/08/2004 09:50:26  ANeillans
{ Continued development.
}
{
{   Rev 1.1    7/28/2004 8:26:46 AM  JPMugaas
{ Further work on the SMTP Server.  Not tested yet.
}
{
{   Rev 1.0    7/27/2004 5:14:38 PM  JPMugaas
{ Start on TIdSMTPServer rewrite.
}
unit IdSMTPServer;

interface
uses
  Classes,
  IdAssignedNumbers,
  IdCmdTCPServer,
  IdCommandHandlers,
  IdContext,
  IdEMailAddress,
  IdException,
  IdExplicitTLSClientServerBase,
  IdReply,
  IdReplyRFC,
  IdReplySMTP,
  IdTCPConnection,
  IdTCPServer,
  IdYarn,
  IdStack;

type
  EIdSMTPServerError = class(EIdException);
  EIdSMTPServerNoRcptTo = class(EIdSMTPServerError);
  TIdMailFromReply = (mAccept, mReject);
  TIdRCPToReply =
    (
    rAddressOk, //address is okay
    rRelayDenied, //we do not relay for third-parties
    rInvalid, //invalid address
    rWillForward, //not local - we will forward
    rNoForward, //not local - will not forward - please use
    rTooManyAddresses, //too many addresses
    rDisabledPerm, //disabled permentantly - not accepting E-Mail
    rDisabledTemp //disabled temporarily - not accepting E-Mail
    );
  TIdDataReply =
    (
    dOk, //accept the mail message
    dMBFull, //Mail box full
    dSystemFull, //no more space on server
    dLocalProcessingError, //local processing error
    dTransactionFailed, //transaction failed
    dLimitExceeded  //exceeded administrative limit
    );
  TIdSMTPServerContext = class;
  TOnUserLoginEvent = procedure(ASender: TIdSMTPServerContext; const AUsername, APassword: string;
    var VAuthenticated: Boolean) of object;
  TOnMailFromEvent = procedure(ASender: TIdSMTPServerContext; const AAddress : string;
    var VAction : TIdMailFromReply) of object;
  TOnRcptToEvent = procedure(ASender: TIdSMTPServerContext; const AAddress : string;
    var VAction : TIdRCPToReply; var VForward : String) of object;
  TOnMsgReceive = procedure(ASender: TIdSMTPServerContext; AMsg : TStream;
    var LAction : TIdDataReply) of object;
  TOnReceived = procedure(ASender: TIdSMTPServerContext; AReceived : String) of object;
  TIdSMTPServer = class(TIdExplicitTLSServer)
  protected
    //events
    FOnUserLogin : TOnUserLoginEvent;
    FOnMailFrom : TOnMailFromEvent;
    FOnRcptTo : TOnRcptToEvent;
    FOnMsgReceive : TOnMsgReceive;
    FOnReceived : TOnReceived;
    //misc
    FServerName : String;
    function DoAuthLogin(ASender: TIdCommand; const Login:string): Boolean;
    //command handlers
    procedure CommandNOOP(ASender: TIdCommand);
    procedure CommandQUIT(ASender: TIdCommand);
    procedure CommandEHLO(ASender: TIdCommand);
    procedure CommandHELO(ASender: TIdCommand);
    procedure CommandAUTH(ASender: TIdCommand);
    procedure CommandMAIL(ASender: TIdCommand);
    procedure CommandRCPT(ASender: TIdCommand);
    procedure CommandDATA(ASender: TIdCommand);
    procedure CommandRSET(ASender: TIdCommand);
    procedure CommandSTARTTLS(ASender: TIdCommand);
    {
    Note that for SMTP, I make a lot of procedures for replies.

    The reason is that we use precise enhanced status codes.  These serve
    as diangostics and give much more information than the 3 number standard replies.
    The enhanced codes will sometimes appear in bounce notices.
    Note: Enhanced status codes should only appear if a client uses EHLO instead of HELO.

    }
    //common reply procs
    procedure AuthFailed(ASender: TIdCommand);
    procedure CmdSyntaxError(AContext: TIdContext; ALine: string; const AReply : TIdReply = nil); overload;
    procedure CmdSyntaxError(ASender: TIdCommand); overload;

    procedure BadSequenceError(ASender: TIdCommand);
    procedure InvalidSyntax(ASender: TIdCommand);
    procedure NoHello(ASender: TIdCommand);
    procedure MustUseTLS(ASender: TIdCommand);
    //Mail From
    procedure MailFromAccept(ASender: TIdCommand; const AAddress : String = '');
    procedure MailFromReject(ASender: TIdCommand; const AAddress : String = '');
    //address replies   - RCPT TO
    procedure AddrValid(ASender: TIdCommand; const AAddress : String = '');
    procedure AddrInvalid(ASender: TIdCommand; const AAddress : String = '');
    procedure AddrWillForward(ASender: TIdCommand; const AAddress : String = '');
    procedure AddrNotWillForward(ASender: TIdCommand; const AAddress : String = ''; const ATo : String = '');
    procedure AddrDisabledPerm(ASender: TIdCommand; const AAddress : String = '');
    procedure AddrDisabledTemp(ASender: TIdCommand; const AAddress : String = '');
    procedure AddrNoRelaying(ASender: TIdCommand; const AAddress : String = '');
    procedure AddrTooManyRecipients(ASender: TIdCommand);
    //mail submit replies
    procedure MailSubmitOk(ASender: TIdCommand);
    procedure MailSubmitLimitExceeded(ASender: TIdCommand);
    procedure MailSubmitStorageExceededFull(ASender: TIdCommand);
    procedure MailSubmitTransactionFailed(ASender: TIdCommand);
    procedure MailSubmitLocalProcessingError(ASender: TIdCommand);
    procedure MailSubmitSystemFull(ASender: TIdCommand);
    procedure SetEnhReply(AReply: TIdReply;
      const ANumericCode: Integer; const AEnhReply, AText: String;
      const IsEHLO: Boolean);
    //  overrides for SMTP
    function GetReplyClass: TIdReplyClass; override;
    function GetRepliesClass: TIdRepliesClass; override;
    procedure InitComponent; override;
    procedure DoReplyUnknownCommand(AContext: TIdContext; ALine: string); override;
    procedure InitializeCommandHandlers; override;
  published
    //events
    property OnMsgReceive : TOnMsgReceive read FOnMsgReceive write FOnMsgReceive;
    property OnUserLogin : TOnUserLoginEvent read FOnUserLogin write FOnUserLogin;
    property OnMailFrom : TOnMailFromEvent read FOnMailFrom write FOnMailFrom;
    property OnRcptTo : TOnRcptToEvent read FOnRcptTo write FOnRcptTo;
    property OnReceived: TOnReceived read FOnReceived write FOnReceived;
    //properties
    property ServerName : String read FServerName write FServerName;
    property DefaultPort default IdPORT_SMTP;
    property UseTLS;
  end;

  TIdSMTPState = (idSMTPNone,idSMTPHelo,idSMTPMail,idSMTPRcpt,idSMTPData);
  TIdSMTPServerContext = class(TIdContext)
  protected
    FSMTPState: TIdSMTPState;
    FFrom: string;
    FRCPTList: TIdEMailAddressList;
    FHELO: Boolean;
    FEHLO: Boolean;
    FHeloString: String;
    FUsername: string;
    FPassword: string;
    FLoggedIn: Boolean;
    FPipeLining : Boolean;
    FFinalStage : Boolean;
    function GetUsingTLS:boolean;
    procedure SetPipeLining(const AValue : Boolean);
  public
    constructor Create(
      AConnection: TIdTCPConnection;
      AYarn: TIdYarn;
      AList: TThreadList = nil
      ); override;
    destructor Destroy; override;
    procedure CheckPipeLine;
    property SMTPState: TIdSMTPState read FSMTPState write FSMTPState;
    property From: string read FFrom write FFrom;
    property RCPTList: TIdEMailAddressList read FRCPTList write FRCPTList;
    property HELO: Boolean read FHELO write FHELO;
    property EHLO: Boolean read FEHLO write FEHLO;
    property HeloString : String read FHeloString write FHeloString;
    property Username: string read FUsername write FUsername;
    property Password: string read FPassword write FPassword;
    property LoggedIn: Boolean read FLoggedIn write FLoggedIn;
    property FinalStage: Boolean read FFinalStage write FFinalStage;
    property UsingTLS:boolean read GetUsingTLS;
    property PipeLining : Boolean read FPipeLining write SetPipeLining;
    //
  end;

const
 IdSMTPSvrReceivedString = 'Received: from $hostname[$ipaddress] (helo=$helo) by $svrhostname[$svripaddress] with $protocol ($servername)'; {do not localize}

implementation

uses
  IdCoderMIME,
  IdGlobal,
  IdGlobalProtocols,
  IdResourceStringsProtocols,
  IdSSL,
  SysUtils;

{ TIdSMTPServer }

procedure TIdSMTPServer.CmdSyntaxError(AContext: TIdContext; ALine: string;
  const AReply: TIdReply);
var LTmp : String;
  i : Integer;
  LReply : TIdReply;
const
  LWhiteSet = [TAB, CHAR32];    {Do not Localize}
begin
  LTmp := ALine;
  //First make the first word uppercase
  for i := 1 to Length(LTmp) do
  begin
    if CharIsInSet(LTmp,i,LWhiteSet) then
    begin
      Break;
    end
    else
    begin
      LTmp[i] := UpCase(LTmp[i]);
    end;
  end;
  try
    if Assigned(AReply) then
    begin
      LReply := AReply;
    end
    else
    begin
      LReply := FReplyClass.Create(nil, ReplyTexts);
      LReply.Assign(ReplyUnknownCommand);
    end;
//    LReply.Text.Clear;
   if (AContext as TIdSMTPServerContext).Ehlo then begin
     (LReply as TIdReplySMTP).SetEnhReply(500, '5.0.0', Format(RSFTPCmdNotRecognized,[LTmp])); {do not localize}
   end else begin
     LReply.SetReply(500, Format(RSFTPCmdNotRecognized,[LTmp]));
   end;
//    LReply.Text.Add(Format(RSFTPCmdNotRecognized,[LTmp]));
    AContext.Connection.IOHandler.Write(LReply.FormattedReply);
  finally
    if not Assigned(AReply) then begin
      FreeAndNil(LReply);
    end;
  end;
end;

procedure TIdSMTPServer.BadSequenceError(ASender: TIdCommand);
begin
  SetEnhReply(ASender.Reply,503,Id_EHR_PR_OTHER_PERM,RSSMTPSvrBadSequence,
   (ASender.Context as TIdSMTPServerContext).EHLO);
end;

procedure TIdSMTPServer.CmdSyntaxError(ASender: TIdCommand);
begin
  CmdSyntaxError(ASender.Context, ASender.RawLine, FReplyUnknownCommand );
  ASender.PerformReply := False;
end;

procedure TIdSMTPServer.CommandEHLO(ASender: TIdCommand);
var LS : TIdReplySMTP;
    LContext : TIdSMTPServerContext;
begin
  LContext := ASender.Context as TIdSMTPServerContext;
  LS := ASender.Reply as TIdReplySMTP;
  LS.SetEnhReply(250,'',Format(RSSMTPSvrHello, [ASender.UnparsedParams]));
  if Assigned(FOnUserLogin) then
  begin
    LS.Text.Add('AUTH LOGIN');    {Do not Localize}
  end;
  LS.Text.Add('ENHANCEDSTATUSCODES'); {do not localize}
  LS.Text.Add('PIPELINING'); {do not localize}
  if FUseTLS in ExplicitTLSVals then
  begin
    LS.Text.Add('STARTTLS');    {Do not Localize}
  end;
  LContext.EHLO := True;
  LContext.SMTPState := idSMTPHelo;
  LContext.HeloString := ASender.UnparsedParams;
  LContext.SMTPState := idSMTPHelo;
end;

procedure TIdSMTPServer.DoReplyUnknownCommand(AContext: TIdContext;
  ALine: string);
begin
  CmdSyntaxError(AContext,ALine);
end;

function TIdSMTPServer.GetRepliesClass: TIdRepliesClass;
begin
  Result := TIdRepliesSMTP;
end;

function TIdSMTPServer.GetReplyClass: TIdReplyClass;
begin
  Result := TIdReplySMTP;
end;

procedure TIdSMTPServer.InitComponent;
var LS : TIdReplySMTP;
begin
  inherited;
  FContextClass := TIdSMTPServerContext;
  HelpReply.Code := ''; //we will handle the help ourselves
  FRegularProtPort := IdPORT_SMTP;
  FImplicitTLSProtPort := IdPORT_ssmtp;