Email服务器

开发平台：
Delphi

SmtpServer.pas：源码内容
							unit SmtpServer;
(******************************************************************************)
(*                                                                            *)
(* SMTP Server Objects                                                        *)
(* Part of Hermes SMTP/POP3 Server.                                           *)
(* Copyright(C) 2000 by Alexander J. Fanti, All Rights Reserver Worldwide.    *)
(*                                                                            *)
(* Contains: TSmtpServer, TSmtpConnection                                     *)
(*                                                                            *)
(* Created January 12, 2000 by Alexander J. Fanti.  See License.txt           *)
(*                                                                            *)
(* Depends on: MailRouting (ListServer, MailDeliver)                          *)
(*             DataU1                                                         *)
(*             UtilU1                                                         *)
(*                                                                            *)
(* Also Uses: WSocket (Francois Piette Internet Component Suite)              *)
(*                                                                            *)
(* Used by: Main                                                              *)
(*                                                                            *)
(* Description:                                                               *)
(* TSmtpServer - This server object manages the Smtp connections, controls    *)
(*               listening for connections, and accepts them.                 *)
(* TSmtpConnection - The Connection object is the real server.  It handles    *)
(*                   the individual Smtp connection, and any requests by the  *)
(*                   connected user.                                          *)
(*                                                                            *)
(* Revisions: 1/14/2000  AJF  Commented                                       *)
(*            1/21/2000  AJF  Commented                                       *)
(*            2/12/2000  AJF  Added Access control to Smtp Server to deter    *)
(*                            spam                                            *)
(*            2/13/2000  AJF  Re-worked anti-spam to be more user friendly    *)
(*                                                                            *)
(******************************************************************************)
interface
uses Classes, SysUtils, FileCtrl, ExtCtrls, INIFiles, Messages, Windows,
     WSocket,
     MailRouting, {TMessageInformation, TListServer, TDeliverMail}
     DataU1;
const
  CRLF = #13 + #10;
  WM_FREECONNECTION = WM_USER + 100;
type
  TSmtpConnection = class;  // Forward declaration of later object
  TSmtpServer_ErrorCode = (sec_CantListen, sec_Bad_Mailbox_Path,
                           sec_SocketError);
  TSmtpServer_StateChange = procedure(Sender : TObject; Active : Boolean;
                                      OpenConnections : Longint) of Object;
  TSmtpServer_StatusUpdate = procedure(Sender : TObject; Status : String;
                                       Level : Integer) of Object;
  TSmtpServer_Error = procedure(Sender : TObject;
                                ErrorCode : TSmtpServer_ErrorCode) of Object;
  TSmtpServer = class(TWHComponent)
  private
    FSocket : TWSocket;        // Socket for Listening for Smtp requests
    ConnectionList : TList;    // List of TSmtpConnection objects currently open
    // Bind address, Port, server name, mailboxpath, queuepath and other
    // Smtp Server settings come straight from global INI object (DataU1)
    FActive : Boolean;   // True when server is listening.  This flag is used
                         // because there are more socket states than listen
                         // and not.  we want to reduce them to 2, a binary.
    FOnStateChange : TSmtpServer_StateChange;   // Event Ptr for OnChangeState
    FOnStatusUpdate : TSmtpServer_StatusUpdate; // Event Ptr for StatusUpdate
    FOnError : TSmtpServer_Error;               // Event Ptr for Server Error
    // We use this to let the connection object tell us when it's finished
    // so we can free it!
    procedure WindowsMessage(Sender : TObject; Msg: TMessage);
    function GetActive : Boolean;            // Read if server's active
    function GetConnectionCount : Longint;   // Read SmtpConnection Count
    // Socket procedures for Listening socket
    procedure SocketSessionAvailable(Sender: TObject; Error: Word);
    procedure SocketChangeState(Sender: TObject;
                                OldState, NewState: TSocketState);
    procedure SocketSessionClosed(Sender: TObject; Error: Word);
    procedure SocketError(Sender: TObject);
    procedure SocketBgException(Sender: TObject; E: Exception;
                                var CanClose: Boolean);
    // Triggered when TSmtpConnection fires a StatusUpdate event
    procedure SmtpConnectionStatusUpdate(Sender : TObject; Status : String;
                                         Level : Integer);
    // Triggered when TSmtpConnection fires a ConnectionClosed event
    procedure SmtpConnectionClosed(Sender : TObject);
    procedure CloseConnection(AConnection : TSmtpConnection);
    procedure CloseAllConnections;
  public
    constructor Create(AOwner : TComponent); Override;
    destructor Destroy; Override;
    // Methods
    procedure Listen;   // Listen for Smtp Connections
    procedure Stop;     // Stop listening for Smtp Connections
    procedure Shutdown; // Stop listening and close all open Smtp Connections
    procedure ConnectionInactivityTimeout(Minutes : Integer);
    // Properties
    property Active : Boolean read GetActive;
    function PublicServerName : String;
    property Count : Longint read GetConnectionCount;
    // Events
    property OnStateChange : TSmtpServer_StateChange    // Fired on Server State
             read FOnStateChange write FOnStateChange;  // Change (Active)
    property OnStatusUpdate : TSmtpServer_StatusUpdate  // Fired on Status
             read FOnStatusUpdate write FOnStatusUpdate;// Update
    property OnError : TSmtpServer_Error                // Fired on Server Error
             read FOnError write FOnError;
  end;
  TSmtpConnection_State = (scs_IDENTIFICATION, scs_WAITCOMMAND,
                           scs_RECEIVINGMAIL, scs_RECEIVINGMAILTO,
                           scs_RECEIVINGMAILDATA);
  TSmtpConnection_StatusUpdate = procedure(Sender : TObject; Status : String;
                                           Level : Integer) of Object;
  TSmtpConnection = class(TComponent)
  private
    FServer : TSmtpServer;
    FSocket : TWSocket;        // Socket for Talking to Smtp User
    FBufferStr : String;       // To buffer commands from Socket
    FState  : TSmtpConnection_State;  // State of Smtp Connection
    FLastActivity : TDateTime; // Time of last activity (for timeout)
    AccCtrl_FromAcceptedAddress : Boolean;  // MAIL FROM is from an Accepted
                                            // IP Address
    AccCtrl_FromBannedAddress   : Boolean;  // MAIL FROM or connection is from
                                            // a banned IP Address
    AccCtrl_FromIPAddress : String; // IP Address of connected sender
    FUserID : String;  // The Machine Address given when they connect
    FMessageInfo : TSmtpMessageInformation;   // Smtp Message information user
                                              // sends us through the connection
    FOnStatusUpdate : TSmtpConnection_StatusUpdate; // Event Ptr for StatusUpd.
    procedure StatusUpdate(Status : String; Level : Integer);
                 // Used internally to Trigger Status Update
    procedure ProcessRequest(UserRequest : String);  // Process Smtp Request
    // Socket Procedures for Connected Socket
    procedure SocketDataAvailable(Sender: TObject; Error: Word);
    procedure SocketDataSent(Sender: TObject; Error: Word);
    procedure SocketSessionClosed(Sender: TObject; Error: Word);
    procedure SocketError(Sender: TObject);
    procedure SocketBgException(Sender: TObject; E: Exception;
                                var CanClose: Boolean);
    procedure Close;                          // Close connection and terminate
  public
    constructor Create(AOwner : TSmtpServer);
    destructor Destroy; Override;
    procedure Accept(SocketHandle : Integer); // Smtp Connection
    property LastActivity : TDateTime read FLastActivity;
    property OnStatusUpdate : TSmtpConnection_StatusUpdate // Fired on Status
             read FOnStatusUpdate write FOnStatusUpdate;   // Update
  end;
implementation
uses UtilU1; {For Domain Name formatting}
(******************************************************************************)
(*                                                                            *)
(*  START SMTP Server Object                                                  *)
(*                                                                            *)
(* This Object listens for connections, accepts them and tracks them.  It     *)
(* also reports on them, and can drop them.                                   *)
(*                                                                            *)
(******************************************************************************)
constructor TSmtpServer.Create(AOwner : TComponent);
begin
  inherited Create(AOwner);
  OnWindowsMessage := WindowsMessage;
  // Initialize variables
  ConnectionList := TList.Create;
  FActive := False;
  // Listening Socket Create and Setup
  FSocket := TWSocket.Create(Self);
  FSocket.OnSessionAvailable := SocketSessionAvailable;
  FSocket.OnChangeState      := SocketChangeState;
  FSocket.OnSessionClosed    := SocketSessionClosed;
  FSocket.OnError            := SocketError;
  FSocket.OnBgException      := SocketBgException;
end;
procedure TSmtpServer.WindowsMessage(Sender : TObject; Msg: TMessage);
begin
  if Msg.Msg = WM_FREECONNECTION then
    CloseConnection(TSmtpConnection(Msg.WParam));
end;
destructor TSmtpServer.Destroy;
begin
  if Assigned(FSocket) then begin
    FSocket.Destroy;
    FSocket := nil;
  end;
  CloseAllConnections;
  ConnectionList.Free;
  inherited Destroy;
end;
procedure TSmtpServer.CloseConnection(AConnection : TSmtpConnection);
var
  x : Longint;
  Connection : TSmtpConnection;
begin
  for x := ConnectionList.Count -1 downto 0 do begin
    Connection := TSmtpConnection(ConnectionList[x]);
    if Connection = AConnection then begin
      ConnectionList.Delete(x);
      AConnection.Free;
      if Assigned(FOnStateChange) then
        OnStateChange(Self, FSocket.State = wsListening, ConnectionList.Count);
    end;
  end;
end;
procedure TSmtpServer.CloseAllConnections;
var
  x : Longint;
  Connection : TSmtpConnection;
begin
  for x := ConnectionList.Count -1 downto 0 do begin
    Connection := TSmtpConnection(ConnectionList[x]);
    CloseConnection(Connection);
  end;
end;
procedure TSmtpServer.ConnectionInactivityTimeout(Minutes : Integer);
const
  HOUR = 0.04167;
  MINUTE = 0.00069;
var
  x : Longint;
  Connection : TSmtpConnection;
  DT : TDateTime;
begin
  // See if there's a connection that hasn't been active for a while
  if Minutes > 0 then begin
    for x := ConnectionList.Count -1 downto 0 do begin
      Connection := TSmtpConnection(ConnectionList[x]);
      DT := Now - Connection.LastActivity;
      if DT > (Minutes * MINUTE) then begin
        if Assigned(FOnStatusUpdate) then
          OnStatusUpdate(Self, '<SMTP ID ' + IntToStr(Integer(Connection)) + '> ' +
                         'Closing due to inactivity (' + IntToStr(Minutes) + ' minutes).',
                         STAT_SERVERERROR);
        CloseConnection(Connection);
      end;
    end;
  end;
end;
function TSmtpServer.GetActive : Boolean;
begin
  FActive := FSocket.State = wsListening;
  Result := FActive;
end;
function TSmtpServer.PublicServerName : String;
begin
  Result := FormatedDomain(INI.ServerName);
end;
function TSmtpServer.GetConnectionCount : Longint;
begin
  Result := ConnectionList.Count;
end;
procedure TSmtpServer.Listen;
begin
  FSocket.Close;
  FSocket.Addr := INI.Smtp_BindAddress;
  FSocket.Port := IntToStr(INI.Smtp_Port);
  FSocket.Proto := 'TCP';
  FSocket.Listen;
end;
procedure TSmtpServer.Stop;
begin
  FSocket.Close;
end;
procedure TSmtpServer.Shutdown;
begin
  Stop;  // Stop listening for new connections
  CloseAllConnections;
end;
procedure TSmtpServer.SocketSessionAvailable(Sender: TObject; Error: Word);
var
  Connection : TSmtpConnection;
begin
  // Smtp Session request
  // Create a new Smtp Connection and accept the request to it...
  Connection := TSmtpConnection.Create(Self);
  Connection.OnStatusUpdate := SmtpConnectionStatusUpdate;
  ConnectionList.Add(Connection);  // Keep track of the connection (add to list)
  if Assigned(FOnStateChange) then
    OnStateChange(Self, FSocket.State = wsListening, ConnectionList.Count);
  Connection.Accept(FSocket.Accept);
end;
procedure TSmtpServer.SocketChangeState(Sender: TObject;
                                        OldState, NewState: TSocketState);
var
  OldActive : Boolean;
begin
  OldActive := FActive;
  FActive := FSocket.State = wsListening;
  if (OldActive <> FActive) and Assigned(FOnStateChange) then
    OnStateChange(Self, FSocket.State = wsListening, ConnectionList.Count);
end;
procedure TSmtpServer.SocketSessionClosed(Sender: TObject; Error: Word);
begin
  if Assigned(FOnStateChange) then
    OnStateChange(Self, FSocket.State = wsListening, ConnectionList.Count);
end;
procedure TSmtpServer.SocketError(Sender: TObject);
var
  Error : Integer;
begin
  // Socket error.  This could be because the listening socket can't bind to
  // the port (10048) or something else.  In fact, bind failure is so common,
  // I'll treat it seperately.
  Error := FSocket.LastError;
  if Error = 10048 then begin // unable to bind to port
    if Assigned(FOnStatusUpdate) then
      OnStatusUpdate(Self, 'Can''t Bind to ' + INI.Smtp_BindAddress +':' +
                           IntToStr(INI.Smtp_Port), STAT_SERVERERROR);
    if Assigned(FOnError) then OnError(Self, sec_CantListen);
  end else begin  // other error
    if Assigned(FOnStatusUpdate) then
      OnStatusUpdate(Self, 'Error #' + IntToStr(FSocket.LastError),
                           STAT_SERVERERROR);
    if Assigned(FOnError) then OnError(Self, sec_SocketError);
  end;
end;
procedure TSmtpServer.SocketBgException(Sender: TObject; E: Exception;
                                        var CanClose: Boolean);
begin
  // Critical Socket Error...
  // This is because something caused an Exception during the socket's
  // processing while it was in an event handler.
  // If the program is good, this will never happen... but...
  CanClose := False;
  if Assigned(FOnStatusUpdate) then
    OnStatusUpdate(Self, 'Unknown BG Exception', STAT_CRITICALERROR);
  if Assigned(FOnError) then OnError(Self, sec_SocketError);
end;
procedure TSmtpServer.SmtpConnectionStatusUpdate(Sender : TObject;
                                                 Status : String;
                                                 Level : Integer);
begin
  // the SmtpConnection has something to report... I'll pass it on,
  // but add where I got it from...
  if Assigned(FOnStatusUpdate) then
    OnStatusUpdate(Self, '<SMTP ID ' +IntToStr(Integer(Sender)) + '> ' +
                   Status, Level);
end;
procedure TSmtpServer.SmtpConnectionClosed(Sender : TObject);
var
  x : Longint;
  Connection : TSmtpConnection;
begin
  // SmtpConnection is letting us know it's destroying itself.
  // we need to remove it from the connection list
  if Sender is TSmtpConnection then
    for x := ConnectionList.Count -1 downto 0 do begin
      Connection := TSmtpConnection(ConnectionList[x]);
      if Connection = Sender then ConnectionList.Delete(x);
    end;
  if Assigned(FOnStateChange) then
    OnStateChange(Self, FSocket.State = wsListening, ConnectionList.Count);
end;
(******************************************************************************)
(*                                                                            *)
(*  STOP  SMTP Server Object                                                  *)
(*                                                                            *)
(******************************************************************************)
(******************************************************************************)
(*                                                                            *)
(*  START SMTP Connection Object                                              *)
(*                                                                            *)
(* The actual Smtp server protocols are implemented here.  This is the real   *)
(* Smtp server code. We try to handle all Smtp requests here and act on       *)
(* whatever we get.                                                           *)
(*                                                                            *)
(* Note, while all commands are implemented, not all replies are possible.    *)
(* this is because we won't do certain things.  For instance, if we can't     *)
(* accept a RCPT TO address, we'll never suggest an alternate route, cause    *)
(* we don't store routing information.  We do DNS every time.                 *)
(*                                                                            *)
(******************************************************************************)
constructor TSmtpConnection.Create(AOwner : TSmtpServer);
begin
  inherited Create(AOwner);
  FServer := TSmtpServer(AOwner);
  // Certain things cannot be done from event handlers.  This is because an
  // event handler is basically a function call.  That means you can't free
  // the sender in the handler, for example. If event handlers were activated
  // by Windows messages, you could, because the code would be
  // object-independant, but then you'd have messages flying everywhere...
  // not pretty.
  //
  // Unfortunately, because of the nature of socket communications, there
  // are some things you really want to do on socket events.  For example,
  // free an object that contains a socket when the socket closes...
  // after all, we don't need it anymore.
  //
  // Well, we need to do it with a Windows message to divorce the object
  // from the event.  I was using TTimers, but this means every connection
  // needs one.  Not too efficient.  So I made a Component that just has a
  // Windows Handle so I could send messages to it, and derived the servers
  // from them.  Now the connections send messages to their servers to close.
  // Initialize variables
  FState := scs_IDENTIFICATION;
  FUserID := '';
  FMessageInfo := TSmtpMessageInformation.Create;
  // Connecting Socket Create and Setup
  FSocket := TWSocket.Create(Self);
  FSocket.OnDataAvailable    := SocketDataAvailable;
  FSocket.OnDataSent         := SocketDataSent;
  FSocket.OnSessionClosed    := SocketSessionClosed;
  FSocket.OnError            := SocketError;
  FSocket.OnBgException      := SocketBgException;
  FBufferStr := '';
end;
destructor TSmtpConnection.Destroy;
begin
  FMessageInfo.Free;
  if Assigned(FSocket) then begin
    FSocket.Destroy;
    FSocket := nil;
  end;
  inherited Destroy;
end;
procedure TSmtpConnection.StatusUpdate(Status : String; Level : Integer);
begin
  if Assigned(FOnStatusUpdate) then OnStatusUpdate(Self, Status, Level);
end;
procedure TSmtpConnection.Accept(SocketHandle : Integer);
var
  Accept : Boolean;
begin
  FSocket.Dup(SocketHandle);
  StatusUpdate('Accepted', STAT_CONNECTIONEVENT);
  // Initialize Connection State
  FState := scs_IDENTIFICATION;
  FMessageInfo.Initialize;
  AccCtrl_FromAcceptedAddress := False;
  AccCtrl_FromBannedAddress   := False;
  AccCtrl_FromIPAddress       := '';
  if FSocket.State = wsConnected then begin
    StatusUpdate('Connected', STAT_CONNECTIONEVENT);
    Accept := True;
    AccCtrl_FromIPAddress := FSocket.GetPeerAddr;
    AccCtrl_FromBannedAddress
      := INI.Smtp_Access_IsThisAddressBanned(AccCtrl_FromIPAddress);
    AccCtrl_FromAcceptedAddress
      := INI.Smtp_Access_IsThisDomainAccepted(AccCtrl_FromIPAddress);
    if INI.Smtp_Access_BanAddresses and AccCtrl_FromBannedAddress then
      Accept := False;
    if Accept then begin
      // Send Greeting
      case INI.Banner_Level of
        bannerlevel_NameVersionService : FSocket.SendStr('220 ' + FServer.PublicServerName + ' Hermes ' + AppVersion + ' SMTP Ready.' + CRLF);
        bannerlevel_NameService        : FSocket.SendStr('220 ' + FServer.PublicServerName + ' Hermes SMTP Ready.' + CRLF);
        bannerlevel_Service            : FSocket.SendStr('220 ' + FServer.PublicServerName + ' SMTP Ready.' + CRLF);
        else FSocket.SendStr('220 ' + FServer.PublicServerName + ' Hermes SMTP Ready.' + CRLF);
      end;
    end else begin
      FSocket.SendStr('221 ' + FServer.PublicServerName +
                      ' Closing Channel, Address banned.' + CRLF);
      FSocket.Close;
      StatusUpdate('Address ' + FUserID + ' BANNED', STAT_COMMANDERROR);
    end;
    // The SMTP specification allows other responses... 221 or 421, for example.
    // These are to let the connected user know that while they connected, they
    // can't talk to us because we're closing, or something.  We won't do that.
    // We simply don't accept a connection if we don't want to talk to a user.
    // If they got this far... we're willing and able to talk.
  end else begin
    //
    // DEBUG
    //
    // Is there ever a time we could accept the connection and then not be
    // connected?  If this happened, we assume the SessionClosed event would
    // fire, thereby closing our connection and object.
    //
    // But we should check this out.
    // This is also seen in the TPop3Connection Object
  end;
end;
procedure TSmtpConnection.Close;
begin
  // We want to close.
  // If the socket is open, close it... if not,
  // send the message that will free this connection object
  if FSocket.State <> wsClosed then FSocket.Close
    else PostMessage(FServer.Handle, WM_FREECONNECTION, Integer(Self), 0);
end;
// procedure SocketSessionConnected(Sender: TObject; Error: Word);
// Not called on accept
procedure TSmtpConnection.SocketDataAvailable(Sender: TObject; Error: Word);
var
  x : Longint;
  len : Integer;                    // Length of data accepted from the socket
  Buffer : Array[0..1023] of Char;  // buffer of data we'll accept from socket
                                    // we add this data to the socket's command
                                    // buffer (FBufferStr) and then parse it
                                    // for CRLF to seperate out commands we
                                    // need to act on.
  UserRequest : String;             // the command we got from the buffer
begin
  // Data is available from the socket for processing.
  // we'll receive the data, and buffer it until we get a CRLF,
  // indicating the end of some sort of command from the client
  len := FSocket.Receive(@Buffer[0], 1024);
  FLastActivity := Now;
  // add to Command Buffer (FBufferStr)
  for x := 0 to len -1 do FBufferStr := FBufferStr + Buffer[x];
  // Process buffer (look for CRLF) and process each command
  while Pos(CRLF, FBufferStr) > 0 do begin
    UserRequest := Copy(FBufferStr, 1, Pos(CRLF, FBufferStr) -1);
    FBufferStr := Copy(FBufferStr, Pos(CRLF, FBufferStr) +2,
                       Length(FBufferStr));
    // Process a command
    ProcessRequest(UserRequest);
  end;
end;
procedure TSmtpConnection.SocketDataSent(Sender: TObject; Error: Word);
begin
  FLastActivity := Now;
end;
procedure TSmtpConnection.ProcessRequest(UserRequest : String);
var
  Command, SubCommand : String;   // User Command and sub-command
  Parameter : String;             // Possible Command Parameter
  x : Longint;
  Accept : Boolean;               // I use this to decide to accept various
                                  // commands from a client (after I've
                                  // considered them, of course!)
  RejectReason : String;  // Reason a mail was rejected!
  AliasID, AliasUser : String;    // When considering who the mail is for,
                                  // we'll use these to determine if it's a
                                  // mail alias, which user it belongs to
  UserInfo : TPop3UserInformation;  // We use this to VeRiFY a user is here
                                    // on the server
  ListInfo : TMailListInformation;      // we use these to EXPaNd a mail list
  ListMember : PMailListMemberInfoRec;  // to its membership if requested
  SL : TStringList;
  ToRoute   : TMessageRouteInformation; // Used to analyze the RCPT TO command
                                        // parameter to decide if we want to
                                        // accept mail bound for the destination
  FromRoute : TMessageRouteInformation; // Used to analyze the MAIL FROM command
                                        // parameter to decide if we want to
                                        // accept mail from the source
  Route : TMessageRouteInformation;
  Deliverer : TDeliverMail;  // Object to handle actual delivery of mail
begin
  // Are we receiving mail data (message data)?  If we are, go to mail
  // data processing, but if we're not, then we're accepting cammands
  if FState <> scs_RECEIVINGMAILDATA then begin
    // Accepting Smtp Commands
    if UserRequest <> '' then begin
      // Seperate out command from parameters to command
      Command := UpperCase(Trim(UserRequest));
      Parameter := '';
      if Pos(' ', UserRequest) > 0 then begin
        Command := UpperCase(Trim(Copy(UserRequest, 1,
                                       Pos(' ', UserRequest))));
        Parameter := Trim(Copy(UserRequest, Pos(' ', UserRequest),
                               Length(UserRequest)));
      end;
      StatusUpdate('Command: ' + Command + ' (' + Parameter + ')',
                   STAT_CONNECTIONEVENT);
      // Process each command
      if (Command = 'HELO') and                    // HELO machine-ID
         (FState = scs_IDENTIFICATION) and
         (FSocket.State = wsConnected) then begin
        // User wants to identify self... Parameter is their ID
        FUserID := Parameter;
        // Here I could decide to accept or not...
        Accept := True;
        // Accept
        if Accept then begin
          // Accept connection request from the user.
          FMessageInfo.Initialize;  // Initialize message buffer
          FState := scs_WAITCOMMAND;
          FSocket.SendStr('250 ' + FServer.PublicServerName + CRLF);
          StatusUpdate('User ' + FUserID + ' at ' + FSocket.GetPeerAddr + ' OK',
                       STAT_COMMANDEVENT);
        end else begin
          // Reject requesting user/machine
          FSocket.SendStr('421 ' + FServer.PublicServerName +
                          ' Closing Channel, Address banned.' + CRLF);
          FSocket.Close;
          StatusUpdate('User ' + FUserID + ' BAD', STAT_COMMANDERROR);
        end;
      end else
      if (Command = 'MAIL') and                   // MAIL FROM:<reverse-path>
         (FState = scs_WAITCOMMAND) and
         (FSocket.State = wsConnected) then begin
        // Verify the command is well-formed (has a FROM:)
        if Pos(':', Parameter) > 0 then begin
          SubCommand := UpperCase(Trim(Copy(Parameter, 1,
                                            Pos(':', Parameter) -1)));
          Parameter := Trim(Copy(Parameter, Pos(':', Parameter) +1,
                                 Length(Parameter)));
          if SubCommand = 'FROM' then begin
            // Analize From (Parameter)
            FromRoute := TMessageRouteInformation.Create(mrte_From);
            x := FromRoute.ParseRoute(Parameter);
            if (x = 0) or (x = 1) then begin
              // X = 1 allows me to accept empty return routes...
              // These are usually failure notices... they're OK
              FMessageInfo.AccCtrl_ToLocalUser        := False;
              FMessageInfo.AccCtrl_ToLocalCount       := 0;
              FMessageInfo.AccCtrl_FromLocalDomain
                := INI.Domain_IsThisOneOfMine(FromRoute.Domain);
              FMessageInfo.AccCtrl_FromLocalUser :=
                FMessageInfo.AccCtrl_FromLocalDomain and
                INI.Mailbox_IsThisOneOfMine(FromRoute.Mailbox);
              FMessageInfo.AccCtrl_FromAcceptedDomain
                := INI.Smtp_Access_IsThisDomainAccepted(FromRoute.Domain);
              FMessageInfo.AccCtrl_FromBannedDomain
                := INI.Smtp_Access_IsThisDomainBanned(FromRoute.Domain);
              FMessageInfo.AccCtrl_FromBannedMailbox
                := INI.Smtp_Access_IsThisMailboxBanned(FromRoute.Mailbox);
              AccCtrl_FromBannedAddress
                := INI.Smtp_Access_IsThisAddressBanned(FromRoute.Domain);
              FMessageInfo.AccCtrl_MessgaeSizeInBytes := 0;
              Accept := True;
              // Here I'll apply my rejection/Acceptance criteria!
              if INI.Smtp_Access_BanDomains and
                 FMessageInfo.AccCtrl_FromBannedDomain then begin
                Accept := False;
                RejectReason := 'Domain (' + FromRoute.Domain + ') Banned';
              end;
              if INI.Smtp_Access_BanMailboxes and
                 FMessageInfo.AccCtrl_FromBannedMailbox then begin
                  Accept := False;
                  RejectReason := 'Mailbox (' + FromRoute.Mailbox + ') Banned';
              end;
              if INI.Smtp_Access_BanAddresses and
                 AccCtrl_FromBannedAddress then begin
                  Accept := False;
                  RejectReason := 'Address (' + FromRoute.Domain + ') Banned';
              end;
              // Here I could reject mail originating from any domain
              // other than one of mine
//              if not INI.Smtp_Forward then
//                Accept := INI.Domain_IsThisOneOfMine(FromRoute.Domain);
              // But I want to get mail from other people...
              // so I'll accept any mail from anywhere...
              if Accept then begin
                // Store the Reverse-Path Route
                FMessageInfo.ReverseRoute.ParseRoute(Parameter);
                // Now I'm ready to accept RCPT TOs
                FState := scs_RECEIVINGMAILTO;
                FSocket.SendStr('250 Sender Accepted' + CRLF);
                StatusUpdate('Mail From (' +
                             FMessageInfo.ReverseRoute.BuildRoute +
                             ') accepted', STAT_COMMANDEVENT);
              end else begin
                // I didn't like the sender, so I'm gonna reject them
                // They can still send other MAIL FROM commands...
                FMessageInfo.Initialize;  // Initialize message buffer
                FState := scs_WAITCOMMAND;
                FSocket.SendStr('550 Sender Not Accepted: ' +
                                RejectReason + CRLF);
                StatusUpdate('Sender BAD (' + RejectReason + ')',
                             STAT_COMMANDERROR);
              end;
            end else begin
              // I can't parse the reverse-path specified...
              // I have to reject the MAIL FROM request
              FSocket.SendStr('501 Reverse-Path not understood' + CRLF);
              StatusUpdate('Bad Reverse Path', STAT_COMMANDERROR);
            end;
            FromRoute.Free;
          end else begin
            // there's no FROM in the Mail command... again it's not correct
            FSocket.SendStr('501 Mail From?' + CRLF);
            StatusUpdate('Missing FROM', STAT_COMMANDERROR);
          end;
        end else begin
          // No : in command... it's not correctly formed
          FSocket.SendStr('501 Mail From?' + CRLF);
          StatusUpdate('Missing :', STAT_COMMANDERROR);
        end;
      end else
      if (Command = 'RCPT') and                  // RCPT TO:<forward-path>
         (FSocket.State = wsConnected) then begin
        // Are we willing to accept RCPT TOs?  Did we accept a MAIL FROM?
        if (FState = scs_RECEIVINGMAILTO) then begin
          FState := scs_RECEIVINGMAILTO;
          // verify the command is well-formed (has a TO:)
          if Pos(':', Parameter) > 0 then begin
            SubCommand := UpperCase(Trim(Copy(Parameter, 1,
                                              Pos(':', Parameter) -1)));
            Parameter := Trim(Copy(Parameter, Pos(':', Parameter) +1,
                                              Length(Parameter)));
            if SubCommand = 'TO' then begin
          // if accept (local or forwardable) 250(local)
          //                               or 251 <forward-path> (forward)
              // Analize To (Parameter)
              ToRoute := TMessageRouteInformation.Create(mrte_To);
              x := ToRoute.ParseRoute(Parameter);
              if x = 0 then begin
                // Here I can reject mail based on who it's going to...
                // I'm going to accept mail for other domains unconditionally...
                // So local users can send mail to non-locals
                Accept := True;
                // But mail for my domain myst have a valid user mailbox...
                if INI.Domain_IsThisOneOfMine(ToRoute.Domain) then begin
                  Accept := False;
                  // then I check lists, users, and aliases
                  if INI.Alias_Exists(ToRoute.Mailbox) or
                     INI.Alias_Exists(ToRoute.Mailbox + '@' + ToRoute.Domain) or // The addressed user could be a fullt qualified mail alias!
                     INI.User_Exists(ToRoute.Mailbox) or
                     INI.List_Exists(ToRoute.Mailbox) then begin
                       StatusUpdate('Mail To is Local', STAT_PROCESSINGEVENT);
                       FMessageInfo.AccCtrl_ToLocalUser := True;
                       Accept := True;
                  end;
                  // I could go further here...
                  // UserInfo : TPop3UserInformation;
                  // I could open the list or user and find out weather the
                  // message was too big, or other stuff if I cared to...
                end;
                if Accept then begin
                  Inc(FMessageInfo.AccCtrl_ToLocalCount);
                  FState := scs_RECEIVINGMAILTO;
                  // Still willing to accept RCPT TOs
                  // Store this Receipient
                  FMessageInfo.AddForwardRoute(Parameter);
                  FSocket.SendStr('250 Destination Accepted' + CRLF);
                  StatusUpdate('Mail To accepted', STAT_COMMANDEVENT);
                end else begin
                  FState := scs_RECEIVINGMAILTO;
                  // Still willing to accept RCPT TOs
                  // I couldn't understand the forward-path route
                  // but that's OK... I'll let then send more...
                  FSocket.SendStr('550 Destination Not Accepted' + CRLF);
                  StatusUpdate('Receiver BAD', STAT_COMMANDERROR);
                end;
              end else begin
                FState := scs_RECEIVINGMAILTO;
                // I couldn't understand the forward-path route
                // but that's OK... I'll let then send more...
                FSocket.SendStr('501 Forward-Path not understood' + CRLF);
                StatusUpdate('Bad Forward Path', STAT_COMMANDERROR);
              end;
              ToRoute.Free;
            end else begin
              FState := scs_WAITCOMMAND;
              // I'm resetting to wait for MAIL FROM again...
              // there's no TO in the Rcpt command... again it's not correct
              FSocket.SendStr('501 Mail To?' + CRLF);
              StatusUpdate('Missing TO', STAT_COMMANDERROR);
            end;
          end else begin
            FState := scs_WAITCOMMAND;
            // I'm resetting to wait for MAIL FROM again...
            // No : in command... it's not correctly formed
            FSocket.SendStr('501 Mail To?' + CRLF);
            StatusUpdate('Missing :', STAT_COMMANDERROR);
          end;
        end else begin
          FState := scs_WAITCOMMAND;
          // I'm resetting to wait for MAIL FROM again...
          // I havn't accepted the MAIL FROM command yet.  This is premature
          FSocket.SendStr('503 Please Mail From before RCPT' + CRLF);
          StatusUpdate('No From yet, how can we have Tos?', STAT_COMMANDERROR);
        end;
      end else
      if (Command = 'DATA') and                  // DATA
         (FSocket.State = wsConnected) then begin
        // User wants to send me some mail data (actual message)
        // THey had better already have given me one Rcpt To route
        if (FState = scs_RECEIVINGMAILTO) and
           (FMessageInfo.ForwardRouteCount > 0) then begin
          Accept := True;
          if INI.Smtp_Access_Restricted then begin
            if ((not AccCtrl_FromAcceptedAddress) and
                (not FMessageInfo.AccCtrl_FromAcceptedDomain) and
                (not FMessageInfo.AccCtrl_FromLocalUser) and
                (not FMessageInfo.AccCtrl_ToLocalUser)) then begin
              Accept := False;
              if FMessageInfo.AccCtrl_ToLocalUser then
                RejectReason := 'NOT addressed to local user.'
              else
                RejectReason := 'Domain or user NOT Accepted';
            end;
          end;
          if INI.Smtp_Access_OnlyForUnderXUsers and
             (INI.Smtp_Access_OnlyForUsersCount > 0) and
             (FMessageInfo.AccCtrl_ToLocalCount >
              INI.Smtp_Access_OnlyForUsersCount) then begin
            Accept := False;
            RejectReason := 'Too Many Recipients (' +
                            IntToStr(FMessageInfo.AccCtrl_ToLocalCount) + ' > '
                            + IntToStr(INI.Smtp_Access_OnlyForUsersCount) + ')';
          end;
          if Accept then begin
            FState := scs_RECEIVINGMAILDATA;
            FSocket.SendStr('354 Start Mail Input, end with <CRLF>.<CRLF>' + CRLF);
            StatusUpdate('Ready to accept mail', STAT_COMMANDEVENT);
          end else begin
            FMessageInfo.Initialize;  // Initialize message buffer
            FState := scs_WAITCOMMAND;
            FSocket.SendStr('451 Error in processing: ' + RejectReason + CRLF);
            StatusUpdate('Mail Rejected: ' + RejectReason, STAT_COMMANDERROR);
          end;
        end else begin
          // I've never gotten a rcpt to route...
          FSocket.SendStr('503 Please RCPT TO before DATA' + CRLF);
          StatusUpdate('No To yet, how can we have Data?', STAT_COMMANDERROR);
        end;
      end else
      if (Command = 'RSET') and                  // RSET
//         (FState = scs_WAITCOMMAND) and
         (FSocket.State = wsConnected) then begin
        // Reset connection and drop mail in progress
        // OK.
        FState := scs_WAITCOMMAND;
        FMessageInfo.Initialize;  // Initialize message buffer
        FSocket.SendStr('250 Ready.' + CRLF);
        StatusUpdate('Connection Reset', STAT_COMMANDEVENT);
      end else
      if (Command = 'SEND') and                  // SEND FROM:<reverse-path>
         (FState = scs_WAITCOMMAND) and
         (FSocket.State = wsConnected) then begin
        // Send to user terminal... no terminals, so not implemented
        FState := scs_WAITCOMMAND;
        FSocket.SendStr('502 SEND not implemented.' + CRLF);
        StatusUpdate('Command not implemented', STAT_COMMANDERROR);
      end else
      if (Command = 'SOML') and                  // SOML FROM:<reverse-path>
         (FState = scs_WAITCOMMAND) and
         (FSocket.State = wsConnected) then begin
        // Send to user terminal... OR Mail...
        // Not implemented.  I could mail here... but
        // I'm not gonna.  Let them MAIL if they want to MAIL
        FState := scs_WAITCOMMAND;
        FSocket.SendStr('502 SOML not implemented.' + CRLF);
        StatusUpdate('Command not implemented', STAT_COMMANDERROR);
      end else
      if (Command = 'SAML') and                  // SAML FROM:<reverse-path>
         (FState = scs_WAITCOMMAND) and
         (FSocket.State = wsConnected) then begin
        // Send to user terminal... AND Mail...
        // Not implemented.  I could mail here... but
        // I'm not gonna.  Let them MAIL if they want to MAIL
        FState := scs_WAITCOMMAND;
        FSocket.SendStr('502 SAML not implemented.' + CRLF);
        StatusUpdate('Command not implemented', STAT_COMMANDERROR);
      end else
      if (Command = 'VRFY') and                  // VRFY <user>
         (FState = scs_WAITCOMMAND) and
         (FSocket.State = wsConnected) then begin
        // Verify a user is valid...
        // see if it's an alias, and if so, recover real UserID
        if INI.Alias_Exists(Parameter) then begin
          Parameter := INI.Alias_Find(Parameter);
          INI.Alias_Parse(Parameter, AliasID, AliasUser);
          Parameter := AliasUser;
          StatusUpdate('Alias Converted', STAT_COMMANDEVENT);
        end;
        // Parameter is UserID
        if INI.User_Exists(Parameter) then begin
          // The user is a valid user on this system...
          UserInfo := TPop3UserInformation.Create;
          UserInfo.LoadFromFile(Parameter);
          // we can decide how to reply now
          // Maybe user wants to hide himself?
          Accept := not UserInfo.UB_DoNotReportUserExists_SMTP;
          if Accept then begin
            // DEBUG
            // It needs to be a routeable response...
            // I think this'll work but I'm not certain...
            FSocket.SendStr('250 ' + UserInfo.RealName + ' <' +
                            FormatedAddress(Parameter, INI.ServerName) +
                            '>' + CRLF);
            StatusUpdate('User Reported', STAT_COMMANDEVENT);
          end else begin
            // Couldn't report on user... they want to stay hidden
            FSocket.SendStr('550 User Unknown' + CRLF);
            StatusUpdate('User is Hidden', STAT_COMMANDERROR);
          end;
          UserInfo.Free;
        end else begin
          // Couldn't find user...
          FSocket.SendStr('550 User Unknown' + CRLF);
          StatusUpdate('User is Unknown', STAT_COMMANDERROR);
        end;
      end else
      if (Command = 'EXPN') and                  // EXPN <list>
         (FState = scs_WAITCOMMAND) and
         (FSocket.State = wsConnected) then begin
        // User wants information on a Mail List...
        // the list name is given in Parameter
        if INI.List_Exists(Parameter) then begin
          // The list exists here, not get list information
          ListInfo := TMailListInformation.Create;
          ListInfo.LoadFromFile(Parameter);
          // we can decide how to reply now
          // Maybe List wants to hide members?
          Accept := not ListInfo.LB_DoNotReportListMembers_SMTP;
          if Accept then begin
            // Reply with list membership
            // Build a StringList of the responses...
            // We want to limit our responses to "Active" and non-"Hidden"
            // list members with routeable addresses.
            SL := TStringList.Create;
            Route := TMessageRouteInformation.Create(mrte_Unknown);
            for x := 0 to ListInfo.MemberCount -1 do begin
              ListMember := ListInfo.Members[x];
              if (ListMember.Active) and (not ListMember.Hidden) and
                 (Route.ParseRoute(ListMember.EMail) = 0) then
                SL.Add(Route.BuildRoute);
            end;
            Route.Free;
            if SL.Count = 0 then begin
              // DEBUG
              // List exists, but has no visible (active and not hidden)
              // members... I'll call this an errer, but I'm not sure it
              // really is...
              FSocket.SendStr('550 List is Empty' + CRLF);
              StatusUpdate('List is Empty', STAT_COMMANDERROR);
            end else
            if SL.Count = 1 then begin
              // The list has one active and visible member... let's report
              FSocket.SendStr('250 ' + SL[0] + CRLF);
              StatusUpdate('List Entry Reported', STAT_COMMANDEVENT);
            end else begin
              // The list has several active and visible members, here they are
              for x := 0 to SL.Count -2 do
                FSocket.SendStr('250-' + SL[x] + CRLF);
              FSocket.SendStr('250 ' + SL[SL.Count -1] + CRLF);
              StatusUpdate('List Entries Reported', STAT_COMMANDEVENT);
            end;
            SL.Free;
          end else begin
            // we didn't accept the request for some reason
            // (like the list is hidden or hiding its membership)
            FSocket.SendStr('550 List Unknown' + CRLF);
            StatusUpdate('List is Hidden', STAT_COMMANDERROR);
          end;
          ListInfo.Free;
        end else begin
          // The listname is unknown.
          FSocket.SendStr('550 List Unknown' + CRLF);
          StatusUpdate('List Unknown', STAT_COMMANDERROR);
        end;
      end else
      if (Command = 'HELP') and                  // HELP <?, optional>
         (FState = scs_WAITCOMMAND) and
         (FSocket.State = wsConnected) then begin
        // User wants some help... yeah right ;-)
        // I've got no help to offer... maybe I'll add this later, but
        // realistically, this is a holdover from the days when the user
        // might have been a human... now they never are.
        FState := scs_WAITCOMMAND;
        FSocket.SendStr('502 No Help Available' + CRLF);
        StatusUpdate('Command not implemented', STAT_COMMANDEVENT);
      end else
      if (Command = 'NOOP') and                  // NOOP
         (FState = scs_WAITCOMMAND) and
         (FSocket.State = wsConnected) then begin
        // User wants to do a "Noop"...
        // No problaemo...
        FState := scs_WAITCOMMAND;
        FSocket.SendStr('250 OK' + CRLF);
        StatusUpdate('No Operation', STAT_COMMANDEVENT);
      end else
      if (Command = 'TURN') and                  // TURN
         (FState = scs_WAITCOMMAND) and
         (FSocket.State = wsConnected) then begin
        // User wants to switch roles.  no thanks.
        // This implementation is not capeable of reversing
        // course because it's implemented as two seperate
        // parts (Server and Agent)
        FState := scs_WAITCOMMAND;
        FSocket.SendStr('502 TURN not permitted.' + CRLF);
        StatusUpdate('Command not implemented', STAT_COMMANDERROR);
      end else
      if (Command = 'QUIT') and                  // QUIT
         (FState = scs_WAITCOMMAND) and
         (FSocket.State = wsConnected) then begin
        // User wants to Quit
        FState := scs_WAITCOMMAND;
//        FSocket.SendStr('250 OK' + CRLF);
        FSocket.SendStr('221 OK, Closed' + CRLF);
        // Mail is processed on receipt of .
        // If I never got it, then mail gets dropped
        StatusUpdate('Closing connection', STAT_CONNECTIONEVENT);
        Close;
      end else
      begin
        // This is not a command I understand
        if FState <> scs_IDENTIFICATION then FState := scs_WAITCOMMAND;
        FSocket.SendStr('500 Command not recognized.' + CRLF);
        StatusUpdate('Command not recognized', STAT_COMMANDERROR);
      end;
    end;
  end else begin
    // We're accepting Mail (message) data....
    if UserRequest = '.' then begin  // end of data
      // if the user sent us just a period (.) then this is the sign that
      // the mail data is finished, and we should try to process it.
      StatusUpdate('Processing Incoming Mail...', STAT_COMMANDEVENT);
      // I need to record the fact that I received this mail in the mail header
      // before trying to deliver it to anybody...
      StatusUpdate('Adding Received to Message Header', STAT_PROCESSINGEVENT);
      FMessageInfo.InsertReceived;
      // Here's the format:
      // Received: from HOST by HOST ; DD MON YY HH:MM:SS ZONE
      // Now I can try to deliver the mail... anyway, this step is successful
      // If there's a delivery failure, then the Smtp Agent will take care of
      // that when it's processing the mail for future delivery...
      Deliverer := TDeliverMail.Create(FMessageInfo);
      Deliverer.OnStatusUpdate := FOnStatusUpdate;
      Deliverer.Deliver;
      Deliverer.Free;
      FMessageInfo.Initialize;
      // Added 5-22-2000 to fix the multi-mail to one mail (compounding) bug!
      // Now I'm ready to accept more commands...
      FState := scs_WAITCOMMAND;
      StatusUpdate('Incoming Mail Processed', STAT_COMMANDEVENT);
      FSocket.SendStr('250 Mail Queued for Delivery' + CRLF);
    end else begin
      // the data the user sent us must be added to the mail message for
      // delivery but if the line starts with a period (.) (but is longer
      // than a period) then we know they padded it to send to us, and we
      // need to remove the first period.
      if Copy(UserRequest, 1, 1) = '.' then  // Remove padded period (.)
        UserRequest := Copy(UserRequest, 2, Length(UserRequest));
      // Add data to message data already stored
      FMessageInfo.Data_AppendLine(UserRequest);
      if INI.LogSpyMessageContent then
        StatusUpdate('Data: ' + UserRequest, STAT_PROCESSINGEVENT);
    end;
  end;
end;
procedure TSmtpConnection.SocketSessionClosed(Sender: TObject; Error: Word);
begin
  StatusUpdate('Closed', STAT_CONNECTIONEVENT);
  // Socket is closed, we must tell Server Object
  // to free this connection.  There's no point to
  // carrying on without a connection, now is there?
  PostMessage(FServer.Handle, WM_FREECONNECTION, Integer(Self), 0);
end;
procedure TSmtpConnection.SocketError(Sender: TObject);
begin
  StatusUpdate('Socket Error', STAT_CONNECTIONERROR);
  // We had a socket error. This isn't a protocol error like the user
  // typed the wrong command, it's a dropped connection, or something else.
  // we'll close on this too, because we don't know how to recover from it.
  // the user can open a new connection if they really want.
  Close; // Close on Error
end;
procedure TSmtpConnection.SocketBgException(Sender: TObject; E: Exception;
                                            var CanClose: Boolean);
begin
  CanClose := False;
  StatusUpdate('Background Exception Error', STAT_CRITICALERROR);
  // We had a background exception.  This is like a socket error in that
  // we don't know what happened, and we don't know how to recover, so
  // we'd better just close this connection.
  Close; // Close on Error
end;
(******************************************************************************)
(*                                                                            *)
(*  STOP  SMTP Connection Object                                              *)
(*                                                                            *)
(******************************************************************************)
(* Bugs Fixed *)
{  // This is not a command I understand
   Was: FState := scs_WAITCOMMAND;
   Now: if FState <> scs_IDENTIFICATION then FState := scs_WAITCOMMAND;
   // Changed because a bad HELO caused us to skip the Identification state.
   // Thanks to "Vassilis Stathopoulos" <vstath@irismedia.gr> on 2/1/00
}
end.

						