www.pudn.com > EmailServer.zip > 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, ' ' +
'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, ' ' +
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:
(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:
(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)
// 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);
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:
(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:
(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:
(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
(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
(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
(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" on 2/1/00
}
end.