idsmtpserver.pas

Indy控件的使用源代码

{ $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:  10325: IdSMTPServer.pas 
{
{   Rev 1.3    16/05/2003 9:24:50 PM  ANeillans
{ Fixed Bug 683558 
}
{
{   Rev 1.2    16/05/2003 9:11:56 PM  ANeillans
{ Fixed Bug 664163 
}
{
{   Rev 1.1    02/05/2003 9:23:48 AM  ANeillans
{ Fixed bug: 730575 
}
{
{   Rev 1.0    2002.11.12 10:51:36 PM  czhower
}
unit IdSMTPServer;

{
 Indy SMTP Server - Version 5.1b

 Original Programmer: Andrew Neillans (E-Mail: [e-mail] HTTP://www.neillans.co.uk)
 No Copyright. Code is given to the Indy Pit Crew.

 Revision History:
 13-Feb-02: Andy
     - Minor changes, just really to make the responses make sense more :)
 09-Jan-02: Andy
     - Added NoEncode option
 28-Nov-01:
     - Added support for FileStreams in place of MemoryStreams (be nice to server-resources time!!)
     - Allen O'Neill [e-mail]
 24-Nov-01:
     - Changes merged, submitted by Sheng Quanhu ([e-mail])
       Adds : SMTPState, CustomError, AuthMode
     - Corrected 'formatting' problems
 15-Sept-01:
     - Corrected LMsg bug - reported on newsgroups by Ing. Schardl robert ([e-mail])
 22-Jul-01:
     - Added NoDecode - Allows you to use the ProcessMessageParsed to do all parsing, except
       the messagebody / messageparts. - 5.0g
 21-Jul-01 - Andy
    - Fixed Al's CommandDATA Changes - some changes in TIdMessageClient also. - 5.0f
 21 July 2001 - Allen O'Neill
    - Fixed CommandDATA OnParsed to use TidIOHandler assignment correctly
 20-Jul-2001:
    - Completed Auth :)
      WARNING! AUTH is UNTESTED! Any problems, e-mail me - address above.
    - Corrected a parsing 'oversight' - Thanks to  Tony McKiernan for finding it :)
 18-Jul-2001:
    - Added Auth Support - 5.0e
 02-Jul-2001:
    - Repaired again - changed in CommandHandler :) - 5.0d
 30-Jun-2001:
    - Modified ProcessRAW.
    - Added CustomError String in RCPT Processing
 29-Jun-2001:
    - Repaired - changes in CommandHandler broke replies. - 5.0c
 28-Jun-2001:
    - Work nearly complete - 99% functionality - 5.0b
    - Completed parsed BCC
 24-Jun-2001 -> 26-Jun-2001 - Andrew
    - Work continues ... 5.0a
 10-May-2001 - Kudzu
    - Extensive work to port to CommandHandler design and other changes
 17-Apr-2001:
    - Some bug fixes :(
 12-Apr-2001:
    - EHLO (along with the associated LOGIN) command now supported.
    - Moved ReceivedHeader and XServer to the Messages section
 19-Feb-2001:
    - Minor updates.
 18-Feb-2001:
    - Another typo correct - RSET was sending a 200 response, instead of a 250.
    - Changes implemented, as asked by Chad Z. Hower <[e-mail]>
 17-Feb-2001: J. Peter Mugaas
   Moved various message properties into Persistant classes so that there is a more
   logical structure and to prevent a developer from being overwhelmed by the various properites
   in one place
   I hard-coded the Error reply codes for the SMTP Protocol and I moved all other constants
   to IdResourceStrings.  I felt I had to hard-code error reply codes in the SMTP Component
   to prevent developers from mistakenly removing or changing those values breaking client
   programs in the process.  Idiot-proofing.
 17-Feb-2001:
    - Added BCC Support (forgot to add it before, sorry.)
 16-Feb-2001:
    - Adjusted EHLOString - now a TStrings :)
 08-Feb-2001:
    - Minor tweaks.
 05-Feb-2001:
    - Added EHLOString Property - this is what is returned when an acceptable EHLO received.
 27-Jan-2001:
    - Added basic Received Header support
 26-Jan-2001:
    - Corrected a small glitch with Message storage.
    - Corrected a typo - incorrect status number is sent when connection established. Was 200,
      should be 220.
 25-Jan-2001:
    - Added new variable - EndData (sent when OnDATAEvent has fired)
 10-Jan-2001:
    - Actually got the modification to work! Thanks to Jan Pedersen <[e-mail]>
 09-Jan-2001:
    - Modified to support TIdMessage
 02-Jan-2001:
    - Added TURN, SOML, VRFY, EXPN, SAML & SEND events, as requested by J. Peter Mugaas.
 31-Dec-2000:
    - Found an error with the component, which only materialises when multiple connections
      attempt to use the MailData : TStrings var - it causes it to save all the information
      as a single email for the first user!
      Fixed it (I hope) by adding a new class to store the session information. Some of
      the new variables in the class are there for future EXPANSION.
 30-Dec-2000:
    - New DCR File, with a much improved icon. Now fits in with the other Indy Icons.
    - Fixed a 'cross over' style bug with EHLO and HELO.    
    - Added a new variables / properties....
        WelcomeString and BasicConnect properties.
         If BasicConnect = True then contents of WelcomeString will be sent to the client,
         with 200 prefixed. This makes the server easier to build / maintain.
        EnableEHLO property.
         If true, the EHLO event can fire, if false it will return a default error.
 29-Dec-2000:
    - Changed some of the syntax of the code, as recommended by J. Peter Mugaas.
    - Nearly a complete rewrite of the procedures
 05-Dec-2000:
    - Corrected a silly error which meant the DATA command was not processed correctly.
    - Changed it so that the SMTPServer Component is now registered onto the Indy Servers Tab.
    - Added the DCR to include an icon - not a good one, but more descriptive than the Delphi Standard.
 04-Dec-2000:
    - Created Unit.
    - Created new SMTP Server Component in accordance to RFC 821

}
interface

uses
  Classes,
  IdTCPClient,
  IdTCPServer,
  IdMessage,
  IdEMailAddress,
  IdCoderMIME,
  IdMessageClient,
  IdIOHandlerSocket,
  IdStack;

type
  TOnReceiveRaw = procedure(ASender: TIdCommand; var VStream: TStream;
    RCPT: TIdEMailAddressList; var CustomError: string) of object;
  TOnReceiveMessage = procedure(ASender: TIdCommand; var AMsg: TIdMessage; RCPT:
    TIdEMailAddressList; var CustomError: string) of object;

  TBasicHandler = procedure(ASender: TIdCommand) of object;
  TUserHandler = procedure(ASender: TIdCommand; var Accept: Boolean; Username,
    Password: string) of object;
  THasAddress = procedure(const ASender: TIdCommand; var Accept, ToForward:
    Boolean; EMailAddress: string; var CustomError: string) of object;
  THasAddress2 = procedure(const ASender: TIdCommand; var Accept: Boolean;
    EMailAddress: string) of object;
  TIdSMTPReceiveMode = (rmRaw, rmMessage, rmMessageParsed);
  TIdStreamType = (stFileStream, stMemoryStream);


  // Start Messages

  TIdSMTPGreeting = class(TPersistent)
  protected
    fHelloReply,
    fNoHello,
    fAuthFailed: string;
    fEHLOReply: TStrings;
    fEHLONotSupported: string;
    procedure SetEHLOReply(const AValue: TStrings);
  public
    constructor Create;
    procedure Assign(Source: TPersistent); override;
    destructor Destroy; override;
  published
    property EHLONotSupported: string read fEHLONotSupported write fEHLONotSupported;
    property HelloReply: string read fHelloReply write fHelloReply;
    property NoHello: string read fNoHello write fNoHello;
    property AuthFailed: string read fAuthFailed write fAuthFailed;
    property EHLOReply: TStrings read FEHLOReply write SetEHLOReply;
  end;

  TIdSMTPRcpReplies = class(TPersistent)
  protected
    fAddressOkReply: string;
    FAddressErrorReply: string;
    FAddressWillForwardReply: string;
  public
    constructor Create;
    procedure Assign(Source: TPersistent); override;
  published
    property AddressOkReply: string read fAddressOkReply write fAddressOkReply;
    property AddressErrorReply: string read FAddressErrorReply write
      FAddressErrorReply;
    property AddressWillForwardReply: string read FAddressWillForwardReply write
      FAddressWillForwardReply;
  end;

  TIdSMTPDataReplies = class(TPersistent)
  public
    fStartDataReply: string;
    fEndDataReply: string;
  public
    constructor Create;
    procedure Assign(Source: TPersistent); override;
  published
    property StartDataReply: string read fStartDataReply write fStartDataReply;
    property EndDataReply: string read fEndDataReply write fEndDataReply;
  end;

  TIdSMTPMessages = class(TPersistent)
  protected
    FNoopReply,
    FRSetReply,
    FQuitReply,
    FErrorReply,
    FSequenceError,
    FNotLoggedIn,
    fReceived,
    fXServer,
    FSyntaxErrorReply: string;

    FDataReplies: TIdSMTPDataReplies;
    FGreeting: TIdSMTPGreeting;
    FRcpReplies: TIdSMTPRcpReplies;
    procedure SetDataReplies(const AValue: TIdSMTPDataReplies);
    procedure SetGreeting(const AValue: TIdSMTPGreeting);
    procedure SetRcpReplies(const AValue: TIdSMTPRcpReplies);
  public
    constructor Create;
    procedure Assign(Source: TPersistent); override;
    destructor Destroy; override;
  published
    property NoopReply: string read FNoopReply write FNoopReply;
    property RSetReply: string read FRSetReply write FRSetReply;
    property QuitReply: string read FQuitReply write FQuitReply;
    property ErrorReply: string read FErrorReply write FErrorReply;
    property SequenceError: string read FSequenceError write FSequenceError;
    property NotLoggedIn: String read FNotLoggedIn write FNotLoggedIn;
    property XServer: string read fXServer write fXServer;
    property ReceivedHeader: string read fReceived write fReceived;
    property SyntaxErrorReply: string read FSyntaxErrorReply write FSyntaxErrorReply;
    property Greeting: TIdSMTPGreeting read FGreeting write SetGreeting;
    property RcpReplies: TIdSMTPRcpReplies read FRcpReplies write SetRcpReplies;
    property DataReplies: TIdSMTPDataReplies read FDataReplies write SetDataReplies;
  end;

  // End Messages

  TIdSMTPServer = class(TIdTCPServer)
  protected
    FOnReceiveRaw: TOnReceiveRaw;
    FOnReceiveMessage: TOnReceiveMessage;
    FOnReceiveMessageParsed: TOnReceiveMessage;
    fAllowEHLO: Boolean;
    fAuthMode: Boolean;
    fNoDecode: Boolean;
    fNoEncode: Boolean;
    fOnCommandRCPT: THasAddress;
    fOnCommandMAIL: THasAddress2;
    fReceiveMode: TIdSMTPReceiveMode;
    fMessages: TIdSMTPMessages;
    fOnCommandHELP,
    fOnCommandSOML,
    fOnCommandSEND,
    fOnCommandSAML,
    fOnCommandVRFY,
    fOnCommandEXPN,
    fOnCommandTURN,
    fOnCommandAUTH: TBasicHandler;
    fCheckUser: TUserHandler;
    //
    procedure CommandData(ASender: TIdCommand);
    procedure CommandMail(ASender: TIdCommand);
    procedure CommandRcpt(ASender: TIdCommand);
    procedure CommandRSET(ASender: TIdCommand);
    procedure CommandHELO(ASender: TIdCommand);
    procedure CommandEHLO(ASender: TIdCommand);
    procedure CommandAUTH(ASender: TIdCommand);
    // Expose to user
    procedure CommandHELP(ASender: TIdCommand);
    procedure CommandSOML(ASender: TIdCommand);
    procedure CommandSEND(ASender: TIdCommand);
    procedure CommandSAML(ASender: TIdCommand);
    procedure CommandVRFY(ASender: TIdCommand);
    procedure CommandEXPN(ASender: TIdCommand);
    procedure CommandTURN(ASender: TIdCommand);
    procedure InitializeCommandHandlers; override;
  private
    FRawStreamType: TIdStreamType;
    // Internal
    function DoAuthLogin(ASender: TIdCommand; const Login: string):Boolean;
    procedure SetRawStreamType(const Value: TIdStreamType);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure SetMessages(AValue: TIdSMTPMessages);
  published
    property AuthMode: Boolean read fAuthMode write fAuthMode;
    property Messages: TIdSMTPMessages read fMessages write SetMessages;
    property OnReceiveRaw: TOnReceiveRaw read FOnReceiveRaw write FOnReceiveRaw;
    property OnReceiveMessage: TOnReceiveMessage read FOnReceiveMessage write
      FOnReceiveMessage;
    property OnReceiveMessageParsed: TOnReceiveMessage read
      FOnReceiveMessageParsed write FOnReceiveMessageParsed;
    property ReceiveMode: TIdSMTPReceiveMode read FReceiveMode write
      FReceiveMode;
    property AllowEHLO: boolean read fAllowEHLO write fAllowEHLO;
    property NoDecode: Boolean read fNoDecode write fNoDecode;
    property NoEncode: Boolean read fNoEncode write fNoEncode;
    property OnCommandRCPT: THasAddress read fOnCommandRCPT write
      fOnCommandRCPT;
    property OnCommandMAIL: THasAddress2 read fOnCommandMAIL write
      fOnCommandMAIL;
    // Expose to user
    property OnCommandAUTH: TBasicHandler read fOnCommandAUTH write
      fOnCommandAUTH;
    property CheckUser: TUserHandler read fCheckUser write fCheckUser;
    property RawStreamType : TIdStreamType read FRawStreamType write SetRawStreamType;
    property OnCommandHELP: TBasicHandler read fOnCommandHelp write
      fOnCommandHelp;
    property OnCommandSOML: TBasicHandler read fOnCommandSoml write
      fOnCommandSoml;
    property OnCommandSEND: TBasicHandler read fOnCommandSend write
      fOnCommandSend;
    property OnCommandSAML: TBasicHandler read fOnCommandSaml write
      fOnCommandSaml;
    property OnCommandVRFY: TBasicHandler read fOnCommandVrfy write
      fOnCommandVrfy;
    property OnCommandEXPN: TBasicHandler read fOnCommandExpn write
      fOnCommandExpn;
    property OnCommandTURN: TBasicHandler read fOnCommandTurn write
      fOnCommandTurn;
  end;

  TIdSMTPState = (idSMTPNone,idSMTPHelo,idSMTPMail,idSMTPRcpt,idSMTPData);
  TIdSMTPServerThread = class(TIdPeerThread)
  protected
    procedure BeforeRun; override;
  public
    SMTPState: TIdSMTPState;
    From: string;
    RCPTList: TIdEMailAddressList;
    HELO: Boolean;
    EHLO: Boolean;
    Username: string;
    Password: string;
    LoggedIn: Boolean;
    //
    constructor Create(ACreateSuspended: Boolean = True); override;
    destructor Destroy; override;
  end;

implementation

uses
  IdGlobal,
  IdResourceStrings,
  SysUtils;

constructor TIdSMTPServer.Create(AOwner: TComponent);
begin
  inherited;
  DefaultPort := 25;
  fAuthMode := false;
  fMessages := TIdSMTPMessages.Create;
  Greeting.Text.Text := RSSMTPSvrWelcome;
  Greeting.NumericCode := 220;
  ReplyUnknownCommand.NumericCode := 500;
  ReplyUnknownCommand.Text.Text := 'Syntax Error';    {Do not Localize}
  ThreadClass := TIdSMTPServerThread;
  if not (csDesigning in ComponentState) then
  begin
  end;