www.pudn.com > EmailServer.zip > SmtpAgent.pas
unit SmtpAgent;
(******************************************************************************)
(* *)
(* SMTP Agent Objects *)
(* Part of Hermes SMTP/POP3 Server. *)
(* Copyright(C) 2000 by Alexander J. Fanti, All Rights Reserver Worldwide. *)
(* *)
(* Created January 18, 2000 by Alexander J. Fanti. See License.txt *)
(* *)
(* Depends on: MailRouting (ListServer, MailDeliver) *)
(* DataU1 *)
(* UtilU1 *)
(* *)
(* Also Uses: WSocket, DNSQuery (Francois Piette Internet Component Suite) *)
(* *)
(* Used by: Main *)
(* *)
(* Description: *)
(* TSmtpAgent - This object manages the Smtp Agent connections, controls *)
(* polling the queue directory and deciding what messages are *)
(* in process and which ones need to be processed still. *)
(* TSmtpAgentConnection - The Agent Connection object is the real Agent. It *)
(* opens a mail item for delivery, determines where it *)
(* must be sent, opens the necessary SMTP connections *)
(* to the relevant servers and sends the mail. It *)
(* keeps track of retries and makes non-deliverable *)
(* replies when necessary. *)
(* *)
(* Revisions: 1/28/2000 AJF Commented *)
(* 3/11/2000 AJF Added MX Lookup timeout
(* *)
(******************************************************************************)
interface
uses Classes, SysUtils, ExtCtrls, FileCtrl, INIFiles, Messages, Windows,
WSocket, DnsQuery, {Francois Piette's Internet Components}
DataU1;
const
CRLF = #13 + #10;
WM_FREECONNECTION = WM_USER + 100;
WM_NEXTHOST = WM_USER + 101;
WM_NEXTSERVER = WM_USER + 102;
type
TSmtpAgentConnection = class;
TSmtpAgent_StateChange = procedure(Sender : TObject; Active : Boolean;
OpenItems : Longint) of Object;
TSmtpAgent_StatusUpdate = procedure(Sender : TObject; Status : String;
Level : Integer) of Object;
TSmtpAgent = class(TWHComponent)
private
ConnectionList : TList; // List of TSmtpAgentConnection objects open
FTimer : TTimer; // Used to commit a queue poll
FServiceingQueueNow : Boolean;
FActive : Boolean; // Should the Queue be re-activates after a poll
FOnStateChange : TSmtpAgent_StateChange; // Event Ptr for OnChangeState
FOnStatusUpdate : TSmtpAgent_StatusUpdate; // Event Ptr for StatusUpdate
// 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);
procedure StatusUpdate(Status : String; Level : Integer);
function GetActive : Boolean; // Read if server's active
function GetConnectionCount : Longint; // Read AgentConnection Count
// Triggered when AgentConnection fires a StatusUpdate event
procedure AgentConnectionStatusUpdate(Sender : TObject; Status : String;
Level : Integer);
// Triggered when AgentConnection fires a ConnectionClosed event
procedure AgentConnectionClosed(Sender : TObject);
procedure ProcessQueue(Sender : TObject);
procedure CloseConnection(AConnection : TSmtpAgentConnection);
procedure CloseAllConnections;
public
constructor Create(AOwner : TComponent); Override;
destructor Destroy; Override;
// Methods
procedure Start; // Start Polling Queue for jobs
procedure ServiceQueue;
procedure Stop; // Stop Polling Queue for jobs
procedure Shutdown; // Stop Polling Queue for jobs and close all open jobs
procedure ConnectionInactivityTimeout(Minutes : Integer);
// Check all connections for inactivity
// Used by TPop3Connection to see if "MailBox Locked" meaning someone is
// already talking to the mailbox (that user's logged in from elsewhere)
function IsMailAlreadyOpen(OpenAgentConn : TSmtpAgentConnection;
MailID : String) : Boolean;
// Properties
property Active : Boolean read GetActive;
property Count : Longint read GetConnectionCount;
// Events
property OnStateChange : TSmtpAgent_StateChange // Fired on Server State
read FOnStateChange write FOnStateChange; // Change (Active)
property OnStatusUpdate : TSmtpAgent_StatusUpdate // Fired on Status
read FOnStatusUpdate write FOnStatusUpdate; // Update
end;
(* This set of objects and structures is going to allow us to arrange
and manage the message we must forward in a easy and convenient way.
Here's what it looks like:
Message (Reverse-Path,
Data,
Retry Info,
Host -> (Status,
Status Message,
ForwardPath -> (Forward-Path, Accepted)
)
)
*)
TSmtpAgentOneForwardRoute = record
ForwardRoute : String[255]; // The actual forward-path as sent in
// SMTP session (<> bracketed)
Accepted : Boolean; // Was this forward-path accepted by the
// server in our forward attempt?
end;
PSmtpAgentOneForwardRoute = ^TSmtpAgentOneForwardRoute;
TSmtpAgentForwardInformation_Status = (afis_Unknown,
afis_DNSFailed,
afis_ConnectFailed,
afis_ServerRejectedFrom,
afis_ServerRejectedTo,
afis_ServerRejectedData,
afis_OK);
TSmtpAgentForwardInformation = class(TObject)
FHost : String; // Host to contact (no <>, may be IP address or name)
FStatus : TSmtpAgentForwardInformation_Status;
FStatusMessage : String;
FForwardRoute : TList; // of PSmtpAgentForwardPathInformation pointers
function GetForwardRoute(Index : Longint) : PSmtpAgentOneForwardRoute;
function GetForwardRouteCount : Longint;
function GetActiveCount : Longint;
public
constructor Create;
destructor Destroy; Override;
procedure Initialize;
property Host : String read FHost;
property Status : TSmtpAgentForwardInformation_Status
read FStatus write FStatus;
property StatusMessage : String read FStatusMessage write FStatusMessage;
property ForwardRouteCount : Longint read GetForwardRouteCount;
property ForwardRoute[Index : Longint] : PSmtpAgentOneForwardRoute
read GetForwardRoute;
procedure ForwardRouteDelete(Index : Longint);
procedure ClearForwardRoutes;
property ActiveCount : Longint read GetActiveCount;
procedure Purge;
end;
TSmtpAgentMessageInformation = class(TObject)
FMailID : String; // The message ID we loaded originally...
FReverseRoute : String; // The actual reverse-path as sent in
// SMTP session (<> bracketed)
FForwardRouteInfo : TList; // of TSmtpAgentForwardInformation objects
FData : TStringList; // Actual mail data (to deliver)
FRetriesPerformed, FRetriesRemaining : Integer;
function GetForwardRouteInfo(Index : Longint) :TSmtpAgentForwardInformation;
function GetForwardRouteInfoCount : Longint;
function SaveToFile(MailID : String) : Boolean; Overload;
public
constructor Create;
destructor Destroy; Override;
procedure Initialize;
property ReversePath : String read FReverseRoute;
property Data : TStringlist read FData;
property RetriesPerformed : Integer
read FRetriesPerformed write FRetriesPerformed;
property RetriesRemaining : Integer
read FRetriesRemaining write FRetriesRemaining;
function LoadFromFile(MailID : String) : Boolean;
function SaveToFile : Boolean; Overload;
function DeleteFile : Boolean;
property ForwardPathInfoCount : Longint read GetForwardRouteInfoCount;
property ForwardPathInfo[Index : Longint] : TSmtpAgentForwardInformation
read GetForwardRouteInfo;
procedure ForwardRouteInfoDelete(Index : Longint);
procedure ClearForwardRouteInfos;
procedure Purge;
end;
TSmtpAgentConnection_State = (sas_WAITCONNECT,
sas_WAITHELO,
sas_WAITMAILFROM,
sas_WAITMAILTO,
sas_WAITMAILDATA,
sas_WAITMAILOK,
sas_WAITCLOSE);
TSmtpAgentConnection_Error = (sae_None, sae_DNSFailure);
TSmtpAgentConnection_StatusUpdate = procedure(Sender : TObject;
Status : String;
Level : Integer) of Object;
TSmtpAgentConnection = class(TWHComponent)
private
FServer : TSmtpAgent;
FDNS : TDNSQuery; // DNS resolution component
FSocket : TWSocket; // Socket for Talking to Smtp Server
FBufferStr : String; // To buffer commands from Socket
FDNSTimeoutTimer : TTimer;
FLastActivity : TDateTime; // Time of last activity (for timeout)
FServerList : TStringList; // List of MX Domains to use for Mail delivery...
// in order of preference
FromIndex : Longint;
FDidWeConnect : Boolean; // True only when we were connected, but we're
// now closed and we didn't expect this to happen.
// We set this to false before trying to connect to a server, and
// to true after successful connection, and then back to false just
// before we break the connection so we know if we're closed while it's
// true, we didn't want to close, and we'll try the next server...
FState : TSmtpAgentConnection_State; // State of Smtp Agent
FError : TSmtpAgentConnection_Error;
FMailID : String; // Filename of mail being processed
FMessageInfo : TSmtpAgentMessageInformation;
CurrentForwardInfo : TSmtpAgentForwardInformation;
HostIndex : Longint; // Index to the CurrentForwardInfo
FOnStatusUpdate : TSmtpAgentConnection_StatusUpdate; // Event Ptr StatusUpd.
// 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);
procedure DNSTimeout(Sender : TObject);
procedure StatusUpdate(Status : String; Level : Integer);
// Used internally to Trigger Status Update
procedure ProcessResponse(ServerResponse : String); // Process Smtp Response
procedure CloseSMTPConnection;
procedure ProcessForwardInfo;
procedure ProcessServerAddress;
procedure Finish;
// Socket Procedures for Connected Socket
procedure DNSRequestDone(Sender : TObject; Error : WORD);
procedure SocketDNSRequestDone(Sender : TObject; Error : WORD);
procedure SocketSessionConnected(Sender: TObject; Error: Word);
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 SendUndeliverableReply;
procedure Close; // Close connection and terminate
public
constructor Create(AOwner : TSmtpAgent);
destructor Destroy; Override;
procedure Process(MailID : String);
property MailID : String read FMailID;
property LastActivity : TDateTime read FLastActivity;
property OnStatusUpdate : TSmtpAgentConnection_StatusUpdate // Fired on
read FOnStatusUpdate write FOnStatusUpdate; // Status Update
end;
implementation
uses MailRouting, {Undeliverable Mail}
UtilU1;
(******************************************************************************)
(* *)
(* START Smtp Agent *)
(* *)
(* This object is responsible for starting individual AgentConnection Objects *)
(* as needed. It looks at the Queue every so often, and checks if the files *)
(* there are in process. If not, it starts an AgentConnection for each. *)
(* *)
(******************************************************************************)
constructor TSmtpAgent.Create(AOwner : TComponent);
begin
inherited Create(AOwner);
OnWindowsMessage := WindowsMessage;
ConnectionList := TList.Create;
FServiceingQueueNow := False;
FActive := False;
FTimer := TTimer.Create(Self);
FTimer.Enabled := False;
FTimer.Interval := (INI.Agent_PollingInterval * 1000);
FTimer.OnTimer := ProcessQueue;
end;
procedure TSmtpAgent.WindowsMessage(Sender : TObject; Msg: TMessage);
begin
if Msg.Msg = WM_FREECONNECTION then
CloseConnection(TSmtpAgentConnection(Msg.WParam));
end;
destructor TSmtpAgent.Destroy;
begin
FTimer.Free;
CloseAllConnections;
ConnectionList.Free;
inherited Destroy;
end;
procedure TSmtpAgent.CloseConnection(AConnection : TSmtpAgentConnection);
var
x : Longint;
Connection : TSmtpAgentConnection;
begin
for x := ConnectionList.Count -1 downto 0 do begin
Connection := TSmtpAgentConnection(ConnectionList[x]);
if Connection = AConnection then begin
ConnectionList.Delete(x);
AConnection.Free;
if Assigned(FOnStateChange) then
OnStateChange(Self, FTimer.Enabled, ConnectionList.Count);
end;
end;
end;
procedure TSmtpAgent.CloseAllConnections;
var
x : Longint;
Connection : TSmtpAgentConnection;
begin
for x := ConnectionList.Count -1 downto 0 do begin
Connection := TSmtpAgentConnection(ConnectionList[x]);
CloseConnection(Connection);
end;
end;
procedure TSmtpAgent.ConnectionInactivityTimeout(Minutes : Integer);
const
HOUR = 0.04167;
MINUTE = 0.00069;
var
x : Longint;
Connection : TSmtpAgentConnection;
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 := TSmtpAgentConnection(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;
procedure TSmtpAgent.StatusUpdate(Status : String; Level : Integer);
begin
if Assigned(FOnStatusUpdate) then OnStatusUpdate(Self, Status, Level);
end;
function TSmtpAgent.GetActive : Boolean;
begin
Result := FTimer.Enabled;
end;
function TSmtpAgent.GetConnectionCount : Longint;
begin
Result := ConnectionList.Count;
end;
procedure TSmtpAgent.Start;
begin
FTimer.Interval := (INI.Agent_PollingInterval * 1000);
FTimer.Enabled := True;
if Assigned(FOnStateChange) then
OnStateChange(Self, True, ConnectionList.Count);
end;
procedure TSmtpAgent.ServiceQueue;
begin
ProcessQueue(nil);
end;
procedure TSmtpAgent.Stop;
begin
FTimer.Enabled := False;
if Assigned(FOnStateChange) then
OnStateChange(Self, False, ConnectionList.Count);
end;
procedure TSmtpAgent.Shutdown;
begin
Stop;
CloseAllConnections;
end;
function TSmtpAgent.IsMailAlreadyOpen(OpenAgentConn : TSmtpAgentConnection;
MailID : String) : Boolean;
var
x : Longint;
Connection : TSmtpAgentConnection;
begin
Result := False;
for x := ConnectionList.Count -1 downto 0 do begin
Connection := TSmtpAgentConnection(ConnectionList[x]);
if (LowerCase(Connection.MailID) = LowerCase(MailID)) and
(Connection <> OpenAgentConn) then Result := True;
end;
end;
procedure TSmtpAgent.ProcessQueue(Sender : TObject);
var
x : Longint;
Connection : TSmtpAgentConnection;
SearchRec: TSearchRec;
SearchResult : Longint;
tempStr, tempExt : String;
List : TStringList;
begin
FActive := FTimer.Enabled;
FTimer.Enabled := False;
if not FServiceingQueueNow then begin
FServiceingQueueNow := True;
if DirectoryExists(INI.MailQueuePath) then begin
List := TStringList.Create;
List.Sorted := True;
List.Duplicates := dupIgnore;
// Build list of mail files...
SearchResult := FindFirst(INI.MailQueuePath + '*.*',
faAnyFile, SearchRec);
while SearchResult = 0 do begin
if (SearchRec.Name <> '.') and
(SearchRec.Name <> '..') and
(SearchRec.Name <> '') and
(not (SearchRec.Attr and faDirectory > 0)) then begin
tempStr := ExtractFileName(SearchRec.Name);
tempExt := ExtractFileExt(SearchRec.Name);
if tempExt <> '' then
tempStr := Copy(tempStr, 1, Length(tempStr) - Length(tempExt));
List.Add(tempStr);
end;
SearchResult := FindNext(SearchRec);
end;
SysUtils.FindClose(SearchRec); // conflict with "Windows.FindClose"
if List.Count > 0 then begin
// start agents for the jobs
StatusUpdate('Servicing ' + IntToStr(List.Count) +
' queued messages...', STAT_PROCESSINGEVENT);
for x := 0 to List.Count -1 do begin
if not IsMailAlreadyOpen(nil, List[x]) then begin
StatusUpdate('Servicing message ' + IntToStr(x +1),
STAT_PROCESSINGEVENT);
// Create a new Agent Connection and start it
Connection := TSmtpAgentConnection.Create(Self);
Connection.OnStatusUpdate := AgentConnectionStatusUpdate;
ConnectionList.Add(Connection); // Keep track of the connection
if Assigned(FOnStateChange) then
OnStateChange(Self, True, ConnectionList.Count);
Connection.Process(List[x]);
end else begin
StatusUpdate('Message ' + IntToStr(x +1) + ' already in service.',
STAT_PROCESSINGEVENT);
end;
end;
end;
List.Free;
end;
FServiceingQueueNow := False;
end;
if FActive then FTimer.Enabled := True;
end;
procedure TSmtpAgent.AgentConnectionStatusUpdate(Sender : TObject;
Status : String;
Level : Integer);
begin
if Assigned(FOnStatusUpdate) then
OnStatusUpdate(Self, ' ' +
Status, Level);
end;
procedure TSmtpAgent.AgentConnectionClosed(Sender : TObject);
var
x : Longint;
Connection : TSmtpAgentConnection;
begin
if Sender is TSmtpAgentConnection then begin
// Connection Closed... remove from list
for x := ConnectionList.Count -1 downto 0 do begin
Connection := TSmtpAgentConnection(ConnectionList[x]);
if Connection = Sender then ConnectionList.Delete(x);
end;
end;
if Assigned(FOnStateChange) then
OnStateChange(Self, FTimer.Enabled, ConnectionList.Count);
end;
(******************************************************************************)
(* *)
(* STOP Smtp Agent *)
(* *)
(******************************************************************************)
(******************************************************************************)
(* *)
(* START Smtp Agent Connection *)
(* *)
(* This object is responsible for actually processing a mail message for *)
(* delivery. This means determining it's mal=formed and should be killed *)
(* or opening a connection to the server or servers it's bound for, and *)
(* committing a mail transaction to pass the message along *)
(* *)
(******************************************************************************)
constructor TSmtpAgentConnection.Create(AOwner : TSmtpAgent);
begin
inherited Create(AOwner);
FServer := TSmtpAgent(AOwner);
OnWindowsMessage := WindowsMessage;
// Initialize variables
FState := sas_WAITHELO;
FError := sae_None;
FMailID := '';
FMessageInfo := TSmtpAgentMessageInformation.Create;
CurrentForwardInfo := nil;
HostIndex := 0;
FServerList := TStringList.Create;
FDNSTimeoutTimer := TTimer.Create(Self);
FDNSTimeoutTimer.Enabled := False;
FDNSTimeoutTimer.Interval := (INI.DNSServerTimeout * 1000);
FDNSTimeoutTimer.OnTimer := DNSTimeout;
// Connecting Socket Create and Setup
FDNS := TDNSQuery.Create(Self);
FDns.OnRequestDone := DNSRequestDone;
FSocket := TWSocket.Create(Self);
FSocket.OnDnsLookupDone := SocketDNSRequestDone;
FSocket.OnSessionConnected := SocketSessionConnected;
FSocket.OnDataAvailable := SocketDataAvailable;
FSocket.OnDataSent := SocketDataSent;
FSocket.OnSessionClosed := SocketSessionClosed;
FSocket.OnError := SocketError;
FSocket.OnBgException := SocketBgException;
FBufferStr := '';
end;
{
This is the procedure that allows us to start the processing of another
element from the event handler of the TWSocket. This is done through a
Windows Message.
}
procedure TSmtpAgentConnection.WindowsMessage(Sender : TObject; Msg: TMessage);
begin
if Msg.Msg = WM_NEXTHOST then ProcessForwardInfo;
// Start the next host we need to contact for message delivery
if Msg.Msg = WM_NEXTSERVER then ProcessServerAddress;
// Start the next server we can try to reach the host for message delivery
end;
destructor TSmtpAgentConnection.Destroy;
begin
FServerList.Free;
FMessageInfo.Free;
if Assigned(FDNS) then begin
FDNS.Destroy;
FDNS := nil;
end;
if Assigned(FSocket) then begin
FSocket.Destroy;
FSocket := nil;
end;
// FProcessTimer.Free;
inherited Destroy;
end;
procedure TSmtpAgentConnection.StatusUpdate(Status : String; Level : Integer);
begin
if Assigned(FOnStatusUpdate) then OnStatusUpdate(Self, Status, Level);
end;
procedure TSmtpAgentConnection.Close;
begin
// We want to close.
// send the message that will free this connection object
PostMessage(FServer.Handle, WM_FREECONNECTION, Integer(Self), 0);
end;
{
This section is concerned with the establishment of connections to SMTP
servers to deliver the mail. We already sorted by server we need to reach
(in the SMTPAgentMessageInformation Object), now we must connect to each
and send the message to the appropriate recepients
}
procedure TSmtpAgentConnection.Process(MailID : String);
begin
FMailID := MailID;
if FMessageInfo.LoadFromFile(FMailID) then begin
FMessageInfo.RetriesPerformed := FMessageInfo.RetriesPerformed +1;
if FMessageInfo.RetriesRemaining >= 0 then begin
HostIndex := FMessageInfo.FForwardRouteInfo.Count;
// HostIndex := -1;
// Start the Process of connecting to the first SMTP server to deliver
// the mail
PostMessage(Handle, WM_NEXTHOST, 0, 0);
end else begin
// we're out of re-tries... better send the non-deliver notice
SendUndeliverableReply;
// Delete the files...
StatusUpdate('Unable to open Mail ' + FMailID +
' for sending... Deleted.', STAT_SERVERERROR);
FMessageInfo.DeleteFile;
end;
end else begin
// can't open mail to send... I don't know why, but we'd better
// Delete the files...
StatusUpdate('Unable to open Mail ' + FMailID + ' for sending... Deleted.',
STAT_SERVERERROR);
FMessageInfo.DeleteFile;
Close;
end;
end;
{
This function is the first step in connecting to a SMTP server to deliver
mail. Remember, there may be multiple target SMTP hosts for a message, so
we might be back here several times.
}
procedure TSmtpAgentConnection.ProcessForwardInfo;
begin
// Inc(HostIndex); // Which host are we looking to contact now?
Dec(HostIndex); // Which host are we looking to contact now?
FState := sas_WAITHELO;
// if HostIndex < FMessageInfo.FForwardRouteInfo.Count then begin
if (HostIndex > -1) and (FMessageInfo.FForwardRouteInfo.Count > 0) then begin
// we select the current host to contact
CurrentForwardInfo := FMessageInfo.FForwardRouteInfo[HostIndex];
if CurrentForwardInfo <> nil then begin
if CurrentForwardInfo.FForwardRoute.Count > 0 then begin
StatusUpdate('Processing ' + CurrentForwardInfo.Host,
STAT_PROCESSINGEVENT);
FServerList.Clear;
if INI.Agent_ForwardToMasterSMTP then begin
if (INI.Agent_MasterServerIPAddress <> '') and
IsDomainDottedIP(INI.Agent_MasterServerIPAddress) then begin
// Forward to master server
StatusUpdate('Forwarding to Master SMTP Server', STAT_SERVERERROR);
FServerList.Add(INI.Agent_MasterServerIPAddress);
// Start trying to contact the servers for the current host
PostMessage(Handle, WM_NEXTSERVER, 0, 0);
end else begin
// Bad Master Server Address
StatusUpdate('Master SMTP Server address invalid.', STAT_SERVERERROR);
end;
end else
if not IsDomainDottedIP(CurrentForwardInfo.Host) then begin
// The host address is a Domain Name. We need to to DNS MX
// resolution on it to get a set of possible hosts to connect to...
if IsDomainDottedIP(INI.DNSServerAddress) then begin
StatusUpdate('Starting DNS MX Lookup', STAT_PROCESSINGEVENT);
FDNS.Addr := INI.DNSServerAddress;
// I'll start the DNS MX resolution on the host in question.
// I'll pick up this line of processing in the DNSRequestDone
// event.
FDNSTimeoutTimer.Enabled := True; // Start DNS Lookup Timer
FDNS.MXLookup(CurrentForwardInfo.Host);
end else begin
// We'd like to do a DNS MX lookup, but the user never gave us a
// DNS Server to check with. This is a problem. We can't deliver
// mail if we can't figure out who to send it to...
StatusUpdate('No DNS Server Available for MX resolution',
STAT_SERVERERROR);
// But even though I can't do an MX lookup... I'll give the host
// itself a shot. Who knows, maybe it's running an SMTP server
// that will talk to me...
FServerList.Add(CurrentForwardInfo.Host);
// Start trying to contact the servers for the current host
PostMessage(Handle, WM_NEXTSERVER, 0, 0);
end;
end else begin
// This host's address is a dotted IP address. We don't need to
// do any DNS MX resolution on it. So we'll add it to the list
// of hosts we intend to try for a connection and proceed.
FServerList.Add(CurrentForwardInfo.Host);
// Start trying to contact the servers for the current host
PostMessage(Handle, WM_NEXTSERVER, 0, 0);
end;
end else begin
// shouldn't be empty of forward paths... but if it is, then
// we skip on to the next forward host... we'll drop this when we
// purge in the "Finish"
PostMessage(Handle, WM_NEXTHOST, 0, 0);
end;
end else begin
// Should never be nil... but if it is, then we're finished.
Finish;
end;
end else begin
// We've run out of hosts to contact for delivery purposes. Time to
// "finish" this mail up...
Finish;
end;
end;
{
This is the result of the DNS MX resolution request for a host.
It will contain zero (0) or more MX records specifying actual hosts
to send the mail to (likely SMTP hosts). These are further described
with a priority we need to observe. These may be IP addresses, but
often they are Domain names themselves which require further DNS
resolution.
}
procedure TSmtpAgentConnection.DNSRequestDone(Sender : TObject; Error : WORD);
type
TMXAnswer = record
Pref : Integer;
Name : String[255];
end;
PMXAnswer = ^TMXAnswer;
var
x : Longint;
MXAnswer : PMXAnswer;
List : TList;
AreWeListed : Boolean;
OurPreference, LowestRec : Longint;
begin
FDNSTimeoutTimer.Enabled := False; // Stop DNS Lookup Timer
// So we have DNS MX results... we should drop any servers in our list of
// servers to try for this host, and build the list from this MX information
FServerList.Clear;
StatusUpdate('Looking up MX', STAT_PROCESSINGEVENT);
if Error = 0 then begin // No Error
if FDNS.ResponseANCount > 0 then begin
// we got back some MX records of servers to try...
// we need to process them
// First we make a list of our own MX result records...
List := TList.Create;
for x := 0 to FDNS.ResponseANCount -1 do begin
GetMem(MXAnswer, SizeOf(TMXAnswer));
MXAnswer.Pref := FDNS.MXPreference[x];
MXAnswer.Name := FDNS.MXExchange[x];
List.Add(MXAnswer);
end;
// Next, we look for ourselves...
AreWeListed := False;
for x := 0 to List.Count -1 do begin
MXAnswer := List[x];
if INI.Domain_IsThisOneOfMine(MXAnswer.Name) then begin
AreWeListed := True;
OurPreference := MXAnswer.Pref;
end;
end;
if AreWeListed then begin
// If we're listed as a valid server for the host...
// we could be in a mail loop. This happens some times, and the
// SMTP spec has told us what we must do...
// We purge ourselves, and all MX records with a higher preference
// than ourselves.
for x := List.Count -1 downto 0 do begin
MXAnswer := List[x];
if MXAnswer.Pref <= OurPreference then begin
FreeMem(MXAnswer, SizeOf(TMXAnswer));
List.Delete(x);
end;
end;
StatusUpdate('Possible Mail Loop from ' + FDNS.QuestionName,
STAT_CRITICALERROR);
end;
// Now we've purged ourself (if we were even there)
// It's time to rank order the MXs by the preference we were told
// by the DNS server...
while List.Count > 0 do begin
MXAnswer := List[0];
LowestRec := 0;
OurPreference := MXAnswer.Pref;
for x := 1 to List.Count -1 do begin
MXAnswer := List[x];
if MXAnswer.Pref < OurPreference then begin
OurPreference := MXAnswer.Pref;
LowestRec := x;
end;
end;
MXAnswer := List[LowestRec];
FServerList.Add(MXAnswer.Name);
FreeMem(MXAnswer, SizeOf(TMXAnswer));
List.Delete(LowestRec);
end;
// Now we've added the servers to try for our current host to the
// Server List. We can drop our temporary MX result list
for x := List.Count -1 downto 0 do begin
MXAnswer := List[x];
FreeMem(MXAnswer, SizeOf(TMXAnswer));
List.Delete(x);
end;
List.Free;
// Finally, if we did all that and have no hosts to try
// possibly because we dropped them all cause we were in the MX result,
// we'll add the original host name to the list just to try.
if FServerList.Count <= 0 then
FServerList.Add(CurrentForwardInfo.Host);
StatusUpdate('MX Results: ' + IntToStr(FServerList.Count),
STAT_PROCESSINGEVENT);
end else begin
// No responses from the DNS server.
// we'll still try the host directly... what the heck
StatusUpdate('No MX Results', STAT_PROCESSINGERROR);
FServerList.Add(CurrentForwardInfo.Host);
end;
end else begin
// DNS failure... we'll try the host directly... what the heck
// it may have an SMTP server there...
StatusUpdate('Failed to look MX', STAT_PROCESSINGERROR);
FServerList.Add(CurrentForwardInfo.Host);
end;
// Start trying to contact the servers for the current host
PostMessage(Handle, WM_NEXTSERVER, 0, 0);
end;
{ IF DNS MX resolution takes too long... move on!}
procedure TSmtpAgentConnection.DNSTimeout(Sender : TObject);
begin
FDNSTimeoutTimer.Enabled := False;
StatusUpdate('MX Resolution Timeout...', STAT_PROCESSINGEVENT);
PostMessage(Handle, WM_NEXTHOST, 0, 0);
end;
{
This is the procedure that goes through the servers in the server list for
the particular host we're working on, and initiates the connection to that
server. We may need to do that through a DNS resolution, or we may do it
directly.
}
procedure TSmtpAgentConnection.ProcessServerAddress;
begin
if FServerList.Count > 0 then begin
if IsDomainDottedIP(FServerList[0]) then begin
// The server address is a dotted IP address and does not require DNS
// resolution. We can initiate the connectuon right here.
StatusUpdate('Connecting to ' + FServerList[0], STAT_PROCESSINGEVENT);
FSocket.Addr := FServerList[0];
FSocket.Port := '25';
FSocket.Proto := 'TCP';
FDidWeConnect := False;
FSocket.Connect;
end else begin
// The server address is a domain name that requires DNS resolution.
// We'll start the DNS resolution here and carry on this line of
// processing in the SocketDNSRequestDone
StatusUpdate('Resolving ' + FServerList[0], STAT_PROCESSINGEVENT);
FSocket.DnsLookup(FServerList[0]);
end;
end else begin
// No servers for the host... Time to progress to the next Host for the
// mail message
CurrentForwardInfo.Status := afis_DNSFailed;
FError := sae_DNSFailure;
PostMessage(Handle, WM_NEXTHOST, 0, 0);
end;
end;
{
We had to get an IP address for a server because it was a domain name, not
an address already. Well, we got it. It's time to try to connect.
}
procedure TSmtpAgentConnection.SocketDNSRequestDone(Sender : TObject; Error : WORD);
var
x : Longint;
begin
StatusUpdate('Resolved ' + FServerList[0] + ' to ' + FSocket.DnsResult, STAT_PROCESSINGEVENT);
// for x := 0 to FSocket.DnsResultList.Count -1 do
// StatusUpdate('Resolved ' + FServerList[0] + ' to ' + FSocket.DnsResultList[x], STAT_PROCESSINGEVENT);
if Error = 0 then begin // No error
// We now have an IP address for the server for the host.
// We try to connect here. We continue this line of processing
// in the SocketSessionConnected
StatusUpdate('Connecting to ' + FSocket.DnsResult, STAT_PROCESSINGEVENT);
FSocket.Addr := FSocket.DNSResult;
FSocket.Port := '25';
FSocket.Proto := 'TCP';
FDidWeConnect := False;
FSocket.Connect;
end else begin
// We did not get a correct response from the DNS server
// We need to progress on to the next address in the server list
// for this host.
StatusUpdate('Unable to resolve ' + FServerList[0], STAT_PROCESSINGERROR);
if FServerList.Count > 0 then FServerList.Delete(0);
PostMessage(Handle, WM_NEXTSERVER, 0, 0);
end;
end;
{
Here we finally connect to an SMTP server for the host we need to
deliver mail to. we need to observe the SMTP protocol from here on out
so we can deliver the message and move on to the next host.
}
procedure TSmtpAgentConnection.SocketSessionConnected(Sender: TObject; Error: Word);
begin
// we were connected... did they say hello ?
if Error = 0 then begin // No Connection Error
// We have connected to the server. We'll set our state machine
// (for the SMTP protocol) here and wait for the server's mandatory
// "220 Hello"
FDidWeConnect := True;
StatusUpdate('Connection Open', STAT_PROCESSINGEVENT);
FromIndex := 0;
FState := sas_WAITCONNECT;
end else begin // Connection Error
// We didn't really connect. The socket's OnClosed event has been
// or will be fired to tell us this. So we need to progress on to
// the next server for this host.
StatusUpdate('Connection Open Failed', STAT_PROCESSINGERROR);
if FServerList.Count > 0 then FServerList.Delete(0);
PostMessage(Handle, WM_NEXTSERVER, 0, 0);
end;
end;
{
This is the procedure to "finish" up our processing of the message.
Here we assess what progress we've made in transmitting the message to
the hosts we needed to contact, for each of the recepients for each
host. If we're successful, then we'll delete the message file. If
we were not successful, then we'll edit the message file to indicate
what we still need to do, and re-queue the message for further processing
later
}
procedure TSmtpAgentConnection.Finish;
begin
// now, we tried all of the hosts and all the tos for each host...
// purge successful hosts and recepients, and save remaining ones...
StatusUpdate('Finishing...', STAT_PROCESSINGEVENT);
FMessageInfo.Purge;
if FMessageInfo.FForwardRouteInfo.Count > 0 then begin
// We didn't deliver to EVERY forward path...
// we need to update the file in the queue to remove successful
// delivery paths and retain the failed ones...
FMessageInfo.RetriesRemaining := FMessageInfo.RetriesRemaining -1;
if FMessageInfo.RetriesRemaining >= 0 then begin
StatusUpdate('Processing partially successful. ' +
'Re-Queueing for further processing...', STAT_SERVERERROR);
FMessageInfo.SaveToFile;
end else begin
// We didn't deliver to everybody, but we may have delivered to some
// Send non-deliver
// DEBUG
// We need to know who it didn't get delivered to...
SendUndeliverableReply;
StatusUpdate('Processing Incomplete, but Retries Used Up. ' +
'Deleting files...', STAT_SERVEREVENT);
FMessageInfo.DeleteFile;
end;
end else begin
// All forward paths were successfully delivered to...
// we can kill this message... it has successfully been delivered.
StatusUpdate('Processing Successful. Deleting files...', STAT_SERVEREVENT);
FMessageInfo.DeleteFile;
end;
// Self-terminate the AgentConnection
Close;
end;
procedure TSmtpAgentConnection.SocketDataAvailable(Sender: TObject; Error: Word);
var
x, len : Integer;
Buffer : Array[0..1023] of Char;
ServerResponse : String;
begin
// Receive data from socket...
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
ServerResponse := Copy(FBufferStr, 1, Pos(CRLF, FBufferStr) -1);
FBufferStr := Copy(FBufferStr, Pos(CRLF, FBufferStr) +2,
Length(FBufferStr));
// Process a command
ProcessResponse(ServerResponse);
end;
end;
procedure TSmtpAgentConnection.SocketDataSent(Sender: TObject; Error: Word);
begin
FLastActivity := Now;
end;
{
Here we actually process server responses and determine
what our next command to the server should be.
}
procedure TSmtpAgentConnection.ProcessResponse(ServerResponse : String);
var
Command, Parameter : String;
Continue : Boolean;
x : Longint;
Route : PSmtpAgentOneForwardRoute;
begin
Command := UpperCase(Trim(ServerResponse));
Parameter := '';
if Pos(' ', ServerResponse) > 0 then begin
Command := UpperCase(Trim(Copy(ServerResponse, 1, 3)));
Continue := Copy(ServerResponse, 4, 1) = '-';
Parameter := Trim(Copy(ServerResponse, 5, Length(ServerResponse)));
// Command := UpperCase(Trim(Copy(ServerResponse, 1,
// Pos(' ', ServerResponse))));
// Parameter := Trim(Copy(ServerResponse, Pos(' ', ServerResponse),
// Length(ServerResponse)));
end;
StatusUpdate('Response: ' + Command + ' (' + Parameter + ')',
STAT_CONNECTIONEVENT);
if Command <> '' then begin
case FState of
sas_WAITCONNECT : begin
// We're waiting for the connection to be established. We need a 220
// from the server before we can proceed...
if Continue then begin // Do nothing... it's a extended command... fuckers!
end else
if (Command = '220') and
(FSocket.State = wsConnected) then begin
// The server is saying hello. we'll promote to the next
// connection state and respond with our own HELO
StatusUpdate('Server said hello', STAT_PROCESSINGEVENT);
StatusUpdate('We say HELO ' + INI.ServerName, STAT_PROCESSINGEVENT);
FState := sas_WAITHELO;
FSocket.SendStr('HELO ' + INI.ServerName + CRLF);
end else begin
// the Server won't talk to us...
// time to mark the failure and progress to next host
StatusUpdate('Server won''t ACK us', STAT_PROCESSINGERROR);
CurrentForwardInfo.Status := afis_ConnectFailed;
CurrentForwardInfo.StatusMessage := Command + ' ' + Parameter;
CloseSMTPConnection;
end;
end;
sas_WAITHELO : begin
// We're waiting for the server to acknowledge our hello...
if Continue then begin // Do nothing... it's a extended command... fuckers!
end else
if (Command = '250') and
(FSocket.State = wsConnected) then begin
// The server acknowledged our hello. We'll promote to the next
// connection state and responde with our MAIL FROM
StatusUpdate('Server accepted our HELO', STAT_PROCESSINGEVENT);
StatusUpdate('We say MAIL FROM: ' + FMessageInfo.ReversePath,
STAT_PROCESSINGEVENT);
FState := sas_WAITMAILFROM;
FSocket.SendStr('MAIL FROM: ' + FMessageInfo.ReversePath + CRLF);
end else begin
// Server won't ack our HELO
// time to mark the failure and progress to next host
StatusUpdate('Server won''t ACK our HELO', STAT_PROCESSINGERROR);
CurrentForwardInfo.Status := afis_ConnectFailed;
CurrentForwardInfo.StatusMessage := Command + ' ' + Parameter;
CloseSMTPConnection;
end;
end;
sas_WAITMAILFROM : begin
// We're waiting for the server to accept our MAIL FROM.
if Continue then begin // Do nothing... it's a extended command... fuckers!
end else
if (Command = '250') and
(FSocket.State = wsConnected) then begin
// The server accepted our MAIL FROM. We'll promote to the next
// connection state and responde with our first RCPT TO
StatusUpdate('Server accepted our MAIL FROM', STAT_PROCESSINGEVENT);
FState := sas_WAITMAILTO;
FromIndex := 0; // should always be a 0 route
if FromIndex < CurrentForwardInfo.FForwardRoute.Count then begin
Route := CurrentForwardInfo.FForwardRoute[FromIndex];
StatusUpdate('We say RCPT TO: ' + Route.ForwardRoute,
STAT_PROCESSINGEVENT);
FSocket.SendStr('RCPT TO: ' + Route.ForwardRoute + CRLF);
end else begin
// We had no rcpt to... why did we connect in the first place?
StatusUpdate('No forward routes... Closing.', STAT_PROCESSINGERROR);
CloseSMTPConnection;
end;
end else begin
// Server won't ack our MAIL FROM...
// time to mark the failure and progress to next host
StatusUpdate('Server won''t ACK our MAIL FROM', STAT_PROCESSINGERROR);
CurrentForwardInfo.Status := afis_ServerRejectedFrom;
CurrentForwardInfo.StatusMessage := Command + ' ' + Parameter;
CloseSMTPConnection;
end;
end;
sas_WAITMAILTO : begin
// We're waiting for the server to acknowledge our RCPT TO.
if Continue then begin // Do nothing... it's a extended command... fuckers!
end else
if ((Command = '250') or (Command = '251')) and
(FSocket.State = wsConnected) then begin
// The server accepted our last RCPT TO. We'll mark it as
// accepted and see if there are more. If so, we'll send another...
// if not, we'll start the data
StatusUpdate('Server accepted our RCPT TO', STAT_PROCESSINGEVENT);
FState := sas_WAITMAILTO;
// mark accepted
Route := CurrentForwardInfo.FForwardRoute[FromIndex];
Route.Accepted := True;
// Next To
Inc(FromIndex);
if FromIndex < CurrentForwardInfo.FForwardRoute.Count then begin
// We move to the next RCPT TO and send it...
Route := CurrentForwardInfo.FForwardRoute[FromIndex];
StatusUpdate('We say RCPT TO: ' + Route.ForwardRoute,
STAT_PROCESSINGEVENT);
FSocket.SendStr('RCPT TO: ' + Route.ForwardRoute + CRLF);
end else begin
// we've sent all of our RCPT TOs
// We'll promote to the next connection state and
// respond with our DATA
StatusUpdate('We say DATA', STAT_PROCESSINGEVENT);
FState := sas_WAITMAILDATA;
FSocket.SendStr('DATA' + CRLF);
end;
end else
if (Command = '550') and
(FSocket.State = wsConnected) then begin
// The server rejected our last RCPT TO. We'll mark it as
// NOT accepted and see if there are more. If so, we'll send
// another. If not, we'll start the data
StatusUpdate('Server rejected our RCPT TO, but we''ll carry on...',
STAT_PROCESSINGERROR);
FState := sas_WAITMAILTO;
// mark rejected
Route := CurrentForwardInfo.FForwardRoute[FromIndex];
Route.Accepted := False;
// Next To
Inc(FromIndex);
if FromIndex < CurrentForwardInfo.FForwardRoute.Count then begin
// We move to the next RCPT TO and send it...
Route := CurrentForwardInfo.FForwardRoute[FromIndex];
StatusUpdate('We say RCPT TO: ' + Route.ForwardRoute,
STAT_PROCESSINGEVENT);
FSocket.SendStr('RCPT TO: ' + Route.ForwardRoute + CRLF);
end else begin
// we've sent all of our RCPT TOs
// We'll promote to the next connection state and
// respond with our DATA
StatusUpdate('We say DATA', STAT_PROCESSINGEVENT);
FState := sas_WAITMAILDATA;
FSocket.SendStr('DATA' + CRLF);
end;
end else begin
// The server rejected our last RCPT TO in a hard way.
// We'll roll back the RCPT TOs the server already accepted and
// terminate the connection, moving on to the next Host
StatusUpdate('Server won''t ACK our RCPT TO', STAT_PROCESSINGERROR);
// need to roll back our Accepted tos...
for x := 0 to CurrentForwardInfo.FForwardRoute.COunt -1 do begin
Route := CurrentForwardInfo.FForwardRoute[x];
Route.Accepted := False;
end;
// time to mark the failure and progress to next host
CurrentForwardInfo.Status := afis_ServerRejectedTo;
CurrentForwardInfo.StatusMessage := Command + ' ' + Parameter;
CloseSMTPConnection;
end;
end;
sas_WAITMAILDATA : begin
// We're waiting for the server to acknowledge out DATA
// so we can actually send it
if Continue then begin // Do nothing... it's a extended command... fuckers!
end else
if (Command = '354') and
(FSocket.State = wsConnected) then begin
// The server acknowledged our DATA command and is
// waiting for us to send our data... better send it now!
StatusUpdate('Server ready for our Data', STAT_PROCESSINGEVENT);
StatusUpdate('We send Data', STAT_PROCESSINGEVENT);
FState := sas_WAITMAILOK;
// time to send all mail data...
for x := 0 to FMessageInfo.FData.Count -1 do begin
if x mod 100 = 0 then begin
StatusUpdate('Sending Data (' + IntToStr(x) + ' / ' + IntToStr(FMessageInfo.FData.Count) + ')', STAT_PROCESSINGEVENT);
Sleep(20); // Why did I put this in there?
end;
if Copy(FMessageInfo.FData[x], 1, 1) = '.' then
FSocket.SendStr('.' + FMessageInfo.FData[x] + CRLF)
else
FSocket.SendStr(FMessageInfo.FData[x] + CRLF);
end;
FSocket.SendStr('.' + CRLF);
StatusUpdate('Waiting for server ack.', STAT_PROCESSINGEVENT);
end else begin
// The server rejected our DATA command. This is bad.
// We'll roll back the RCPT TOs the server already accepted and
// terminate the connection, moving on to the next Host
StatusUpdate('Server won''t accepted our Data', STAT_PROCESSINGERROR);
// need to roll back our Accepted tos...
for x := 0 to CurrentForwardInfo.FForwardRoute.Count -1 do begin
Route := CurrentForwardInfo.FForwardRoute[x];
Route.Accepted := False;
end;
// time to mark the failure and progress to next host
CurrentForwardInfo.Status := afis_ServerRejectedData;
CurrentForwardInfo.StatusMessage := Command + ' ' + Parameter;
CloseSMTPConnection;
end;
end;
sas_WAITMAILOK : begin
// We're waiting for the server to acknowledge receipt of our data
// We just sent it all, after all.
if Continue then begin // Do nothing... it's a extended command... fuckers!
end else
if (Command = '250') and
(FSocket.State = wsConnected) then begin
// The Server received our mail and processed it. It's ready
// for additional MAIL FROM commands...
// But we can't give any because we connect a differenc time
// for each of them. We've finished with this server and it's
// time to say good bye.
StatusUpdate('Server accepted our mail', STAT_PROCESSINGEVENT);
StatusUpdate('We say QUIT', STAT_PROCESSINGEVENT);
CloseSMTPConnection;
end else begin
// The server rejected our Mail Data. This is bad.
// We'll roll back the RCPT TOs the server already accepted and
// terminate the connection, moving on to the next Host
// Server won't accept our mail data...
StatusUpdate('Server won''t accepted our mail', STAT_PROCESSINGERROR);
// need to roll back our Accepted tos...
for x := 0 to CurrentForwardInfo.FForwardRoute.Count -1 do begin
Route := CurrentForwardInfo.FForwardRoute[x];
Route.Accepted := False;
end;
// time to mark the failure and progress to next host
CurrentForwardInfo.Status := afis_ServerRejectedData;
CurrentForwardInfo.StatusMessage := Command + ' ' + Parameter;
CloseSMTPConnection;
end;
end;
sas_WAITCLOSE : begin
if Continue then begin // Do nothing... it's a extended command... fuckers!
end else
if Command = '250' then FSocket.Close;
// We said goodbye to the server, and we're waiting for the server's
// goodbye response back. When we get it, we can close... but the server
// has probably already closed the connection by now.
end;
end;
end;
end;
procedure TSmtpAgentConnection.CloseSMTPConnection;
begin
// This is what we'll call to close the connection to the SMTP server.
// We need to do certain things. when we close the connection, as opposed
// to when the connection is closed because of a bad connect or
// a server termination.
FDidWeConnect := False;
FState := sas_WAITCLOSE;
if FSocket.State = wsConnected then FSocket.SendStr('QUIT' + CRLF);
// If we save stuff here... we can remove some users from delivered list...
// now, we tried all the tos for a single host...
// purge successful host and recepients, and save remaining ones...
StatusUpdate('Closing Connection...', STAT_PROCESSINGEVENT);
FMessageInfo.Purge;
FMessageInfo.SaveToFile;
FSocket.Close;
// Progress on to the next Host because if we're terminating the SMTP
// connection, then we got what we could from the server for that host.
PostMessage(Handle, WM_NEXTHOST, 0, 0);
end;
procedure TSmtpAgentConnection.SocketSessionClosed(Sender: TObject; Error: Word);
begin
StatusUpdate('Closed', STAT_PROCESSINGEVENT);
// We don't automatically go to the next "ForwardInfo" here because sometimes
// we need to "ServerAddress" instead... cause the last address we tried was
// bad, but we have more.
// If this is true, we assume there was an unexpected termination from the
// connected server and we'll try the next one.
if FDidWeConnect then PostMessage(Handle, WM_NEXTSERVER, 0, 0);
end;
procedure TSmtpAgentConnection.SocketError(Sender: TObject);
begin
StatusUpdate('Socket Error', STAT_PROCESSINGERROR);
// We had a socket error. This is not a protocol failure, and is not
// the result of a connect problem. It's a connection interruption or
// something. The best thing to do here is to progress on to the next
// host we need to contact
PostMessage(Handle, WM_NEXTHOST, 0, 0);
end;
procedure TSmtpAgentConnection.SocketBgException(Sender: TObject; E: Exception;
var CanClose: Boolean);
begin
CanClose := False;
StatusUpdate('Background Exception Error', STAT_CRITICALERROR);
// We had a background exception. This indicates a problen in one of our
// socket event handlers. Just like a socket error... I don't know what
// else to do but try to carry on with the next host we need to contact
PostMessage(Handle, WM_NEXTHOST, 0, 0);
end;
procedure TSmtpAgentConnection.SendUndeliverableReply;
var
MessageInfo : TSmtpMessageInformation;
ForwardInfo : TSmtpAgentForwardInformation;
OneRoute : PSmtpAgentOneForwardRoute;
Route : TMessageRouteInformation;
x, y : Longint;
Deliverer : TDeliverMail;
begin
MessageInfo := TSmtpMessageInformation.Create;
// Set the routes...
MessageInfo.ReverseRoute.ParseRoute('<>'); // No return for failure notice
MessageInfo.AddForwardRoute(FMessageInfo.ReversePath);
// copy the data in...
MessageInfo.Data_AppendLine('From: Hermes Server ' + INI.ServerName);
MessageInfo.Data_AppendLine('Subject: Undeliverable Mail');
MessageInfo.Data_AppendLine('');
MessageInfo.Data_AppendLine('The following recepients were not reached:');
MessageInfo.Data_AppendLine('');
for x := 0 to FMessageInfo.GetForwardRouteInfoCount -1 do begin
ForwardInfo := FMessageInfo.GetForwardRouteInfo(x);
for y := 0 to ForwardInfo.GetForwardRouteCount -1 do begin
OneRoute := ForwardInfo.GetForwardRoute(y);
MessageInfo.Data_AppendLine(OneRoute.ForwardRoute);
end;
end;
MessageInfo.Data_AppendLine('');
MessageInfo.Data_AppendLine('so the following message ' +
'could not be delivered');
MessageInfo.Data_AppendLine('');
MessageInfo.Data_AppendLine('');
for x := 0 to FMessageInfo.Data.Count -1 do
MessageInfo.Data_AppendLine(FMessageInfo.Data[x]);
// if the forward route is valid, queue for sending
if MessageInfo.ForwardRouteCount > 0 then begin
Route := MessageInfo.ForwardRoute[0];
// if the forward route is local, then deliver...
if INI.Domain_IsThisOneOfMine(Route.Domain) then begin
// then I check lists, users, and aliases
if INI.Alias_Exists(Route.Mailbox) or
INI.User_Exists(Route.Mailbox) or
INI.List_Exists(Route.Mailbox) then begin
// Save locally!
Deliverer := TDeliverMail.Create(MessageInfo);
Deliverer.OnStatusUpdate := FOnStatusUpdate;
Deliverer.Deliver;
Deliverer.Free;
end else begin
// Local user not found!
StatusUpdate('Local Failure Notice to Non-existant user.', STAT_PROCESSINGERROR);
end;
end else begin
if Route.BuildRoute <> '<>' then begin
Deliverer := TDeliverMail.Create(MessageInfo);
Deliverer.OnStatusUpdate := FOnStatusUpdate;
Deliverer.Deliver;
Deliverer.Free;
end else begin
// Foreign user not found!
StatusUpdate('Failure Notice to Non-existant user.', STAT_PROCESSINGERROR);
end;
end;
end;
MessageInfo.Free;
end;
(******************************************************************************)
(* *)
(* STOP Smtp Agent *)
(* *)
(******************************************************************************)
(******************************************************************************)
(* *)
(* START Smtp Agent Forward Information *)
(* *)
(* This is the object that contains all information for a single host *)
(* that needs to be contacted to deliver an SmtpAgentMessageInformation *)
(* Object. This object has a list of recipients and weather each was *)
(* accepted by the host *)
(* *)
(******************************************************************************)
constructor TSmtpAgentForwardInformation.Create;
begin
inherited Create;
FForwardRoute := TList.Create;
Initialize;
end;
destructor TSmtpAgentForwardInformation.Destroy;
begin
ClearForwardRoutes;
FForwardRoute.Free;
inherited Destroy;
end;
procedure TSmtpAgentForwardInformation.ClearForwardRoutes;
var
x : Longint;
ForwardRoute : PSmtpAgentOneForwardRoute;
begin
for x := FForwardRoute.Count -1 downto 0 do begin
ForwardRoute := FForwardRoute[x];
FreeMem(ForwardRoute, SizeOf(TSmtpAgentOneForwardRoute));
FForwardRoute.Delete(x);
end;
end;
procedure TSmtpAgentForwardInformation.Initialize;
begin
FHost := '';
FStatus := afis_Unknown;
FStatusMessage := '';
ClearForwardRoutes;
end;
function TSmtpAgentForwardInformation.GetForwardRoute(Index : Longint)
: PSmtpAgentOneForwardRoute;
begin
Result := nil;
if (Index >= 0) and (Index < FForwardRoute.Count) then
Result := FForwardRoute[Index];
end;
function TSmtpAgentForwardInformation.GetForwardRouteCount : Longint;
begin
Result := FForwardRoute.Count;
end;
procedure TSmtpAgentForwardInformation.ForwardRouteDelete(Index : Longint);
var
ForwardRoute : PSmtpAgentOneForwardRoute;
begin
if (Index >= 0) and (Index < FForwardRoute.Count) then begin
ForwardRoute := FForwardRoute[Index];
FreeMem(ForwardRoute, SizeOf(TSmtpAgentOneForwardRoute));
FForwardRoute.Delete(Index);
end;
end;
procedure TSmtpAgentForwardInformation.Purge;
var
x : Longint;
ForwardRoute : PSmtpAgentOneForwardRoute;
begin
// Drop Forward Routes that have been accepted ONLY
for x := FForwardRoute.Count -1 downto 0 do begin
ForwardRoute := FForwardRoute[x];
if ForwardRoute.Accepted then begin
FreeMem(ForwardRoute, SizeOf(TSmtpAgentOneForwardRoute));
FForwardRoute.Delete(x);
end;
end;
end;
function TSmtpAgentForwardInformation.GetActiveCount : Longint;
var
x, Count : Longint;
ForwardRoute : PSmtpAgentOneForwardRoute;
begin
Count := 0;
for x := 0 to FForwardRoute.Count -1 do begin
ForwardRoute := FForwardRoute[x];
if not ForwardRoute.Accepted then Inc(Count);
end;
Result := Count;
end;
(******************************************************************************)
(* *)
(* STOP Smtp Agent Forward Information *)
(* *)
(******************************************************************************)
(******************************************************************************)
(* *)
(* START Smtp Agent Message Information *)
(* *)
(* This is the object that contains all information for a single message *)
(* The Data, Return path, retry information and all to paths organized by *)
(* Host *)
(* *)
(******************************************************************************)
constructor TSmtpAgentMessageInformation.Create;
begin
inherited Create;
FForwardRouteInfo := TList.Create;
FData := TStringList.Create;
Initialize;
end;
destructor TSmtpAgentMessageInformation.Destroy;
begin
ClearForwardRouteInfos;
FForwardRouteInfo.Free;
FData.Free;
inherited Destroy;
end;
procedure TSmtpAgentMessageInformation.ClearForwardRouteInfos;
var
x : Longint;
RouteInfo : TSmtpAgentForwardInformation;
begin
for x := FForwardRouteInfo.Count -1 downto 0 do begin
RouteInfo := FForwardRouteInfo[x];
RouteInfo.Free;
FForwardRouteInfo.Delete(x);
end;
end;
procedure TSmtpAgentMessageInformation.Initialize;
begin
FMailID := '';
FReverseRoute := '';
FRetriesPerformed := 0;
FRetriesRemaining := 0;
ClearForwardRouteInfos;
FData.Clear;
end;
function TSmtpAgentMessageInformation.GetForwardRouteInfo(Index : Longint)
:TSmtpAgentForwardInformation;
begin
Result := nil;
if (Index >= 0) and (Index < FForwardRouteInfo.Count) then
Result := FForwardRouteInfo[Index];
end;
function TSmtpAgentMessageInformation.GetForwardRouteInfoCount : Longint;
begin
Result := FForwardRouteInfo.Count;
end;
procedure TSmtpAgentMessageInformation.ForwardRouteInfoDelete(Index : Longint);
var
RouteInfo : TSmtpAgentForwardInformation;
begin
if (Index >= 0) and (Index < FForwardRouteInfo.Count) then begin
RouteInfo := FForwardRouteInfo[Index];
RouteInfo.Free;
FForwardRouteInfo.Delete(Index);
end;
end;
procedure TSmtpAgentMessageInformation.Purge;
var
x : Longint;
RouteInfo : TSmtpAgentForwardInformation;
begin
// Drop hosts that were completely delivered to ONLY
for x := FForwardRouteInfo.Count -1 downto 0 do begin
RouteInfo := FForwardRouteInfo[x];
RouteInfo.Purge;
if RouteInfo.ActiveCount = 0 then begin
RouteInfo.Free;
FForwardRouteInfo.Delete(x);
end;
end;
end;
function TSmtpAgentMessageInformation.LoadFromFile(MailID : String) : Boolean;
var
SL, SLforward : TStringList;
x, y : Longint;
tempStr : String;
Found : Boolean;
SearchHost : String;
OneRouteInfo : TMessageRouteInformation;
RouteInfo : TSmtpAgentForwardInformation;
Route : PSmtpAgentOneForwardRoute;
begin
Result := False;
if FileExists(INI.MailQueuePath + MailID + '.txt') then begin
Self.Initialize;
SL := TStringList.Create;
SL.LoadFromFile(INI.MailQueuePath + MailID + '.txt');
if SL.Count > 0 then begin
// Read Reverse Path...
Found := False;
x := 0;
while (x < SL.Count) and (not Found) do begin
tempStr := Trim(SL[x]);
if UpperCase(tempStr) = '[REVERSE PATH]' then begin
Inc(x); // Skip the header line...
// read the From path...
if x < SL.Count then begin
tempStr := Trim(SL[x]);
if UpperCase(Copy(tempStr, 1, 5)) = 'FROM=' then begin
tempStr := Copy(tempStr, 6, Length(tempStr));
if tempStr <> '' then FReverseRoute := tempStr;
end;
end;
Found := True;
end else Inc(x);
end;
// Read Forward Path...
Found := False;
x := 0;
while (x < SL.Count) and (not Found) do begin
tempStr := Trim(SL[x]);
if UpperCase(tempStr) = '[FORWARD PATH]' then begin
Inc(x); // Skip the header line...
// read the To paths...
SLforward := TStringList.Create;
if x < SL.Count then begin
tempStr := Trim(SL[x]);
while (x < SL.Count) and (Copy(tempStr, 1, 1) <> '[') do begin
if UpperCase(Copy(tempStr, 1, 3)) = 'TO=' then begin
tempStr := Copy(tempStr, 4, Length(tempStr));
if tempStr <> '' then SLforward.Add(tempStr);
end;
Inc(x);
tempStr := Trim(SL[x]);
end;
end;
// Process the forward paths
for x := 0 to SLforward.Count -1 do begin
OneRouteInfo := TMessageRouteInformation.Create(mrte_To);
y := OneRouteInfo.ParseRoute(SLforward[x]);
if y = 0 then begin
if OneRouteInfo.Hosts.Count > 0 then SearchHost := UpperCase(OneRouteInfo.Hosts[0])
else SearchHost := UpperCase(OneRouteInfo.Domain);
// Search for match in FForwardRouteInfo
Found := False;
for y := 0 to FForwardRouteInfo.Count -1 do begin
RouteInfo := FForwardRouteInfo[y];
if UpperCase(RouteInfo.Host) = SearchHost then begin
// Add this route to this current Host Route
// should we check for duplicates?... No
GetMem(Route, SizeOf(TSmtpAgentOneForwardRoute));
Route.ForwardRoute := SLforward[x];
Route.Accepted := False;
RouteInfo.FForwardRoute.Add(Route);
Found := True;
end;
end;
if not Found then begin
// make a new RouteInfo for this Host route
RouteInfo := TSmtpAgentForwardInformation.Create;
RouteInfo.FHost := SearchHost;
RouteInfo.Status := afis_Unknown;
RouteInfo.StatusMessage := '';
GetMem(Route, SizeOf(TSmtpAgentOneForwardRoute));
Route.ForwardRoute := SLforward[x];
Route.Accepted := False;
RouteInfo.FForwardRoute.Add(Route);
FForwardRouteInfo.Add(RouteInfo);
end;
end else OneRouteInfo.Free;
end;
SLforward.Free;
Found := True;
end else Inc(x);
end;
// Read Retry Information...
Found := False;
x := 0;
while (x < SL.Count) and (not Found) do begin
tempStr := Trim(SL[x]);
if UpperCase(tempStr) = '[RETRY]' then begin
Inc(x); // Skip the header line...
// read the retry information
if x < SL.Count then begin
tempStr := Trim(SL[x]);
while (x < SL.Count) and (Copy(tempStr, 1, 1) <> '[') do begin
if UpperCase(Copy(tempStr, 1, 10)) = 'PERFORMED=' then begin
tempStr := Copy(tempStr, 11, Length(tempStr));
FRetriesPerformed := StringToInteger(tempStr, 0);
end;
if UpperCase(Copy(tempStr, 1, 10)) = 'REMAINING=' then begin
tempStr := Copy(tempStr, 11, Length(tempStr));
FRetriesRemaining := StringToInteger(tempStr, INI.Smtp_Retries);
end;
Inc(x);
tempStr := Trim(SL[x]);
end;
end;
Found := True;
end else Inc(x);
end;
// Read Mail Data first...
// We know the [Message] data is the last thing in the file... so...
Found := False;
x := 0;
while (x < SL.Count) and (not Found) do begin
tempStr := Trim(SL[x]);
if UpperCase(tempStr) = '[MESSAGE]' then begin
Inc(x); // Skip the header line...
for y := x to SL.Count -1 do FData.Add(SL[y]); // Copy data in...
Found := True;
end else Inc(x);
end;
SL.Free;
FMailID := MailID;
Result := True;
end;
end;
end;
function TSmtpAgentMessageInformation.SaveToFile : Boolean;
begin
Result := SaveToFile(FMailID);
end;
function TSmtpAgentMessageInformation.SaveToFile(MailID : String) : Boolean;
var
SL : TStringList;
x, y : Longint;
RouteInfo : TSmtpAgentForwardInformation;
Route : PSmtpAgentOneForwardRoute;
begin
Result := False;
SL := TStringList.Create;
SL.Add('[Reverse Path]');
SL.Add('From=' + FReverseRoute);
SL.Add('');
SL.Add('[Forward Path]');
for x := 0 to FForwardRouteInfo.Count -1 do begin
RouteInfo := FForwardRouteInfo[x];
for y := 0 to RouteInfo.FForwardRoute.Count -1 do begin
Route := RouteInfo.FForwardRoute[y];
SL.Add('To=' + Route.ForwardRoute);
end;
end;
SL.Add('');
SL.Add('[Retry]');
SL.Add('Performed=' + IntToStr(FRetriesPerformed));
SL.Add('Remaining=' + IntToStr(FRetriesRemaining));
SL.Add('');
SL.Add('[Message]');
for x := 0 to FData.Count -1 do SL.Add(FData[x]);
try
SL.SaveToFile(INI.MailQueuePath + MailID + '.txt');
FMailID := MailID;
Result := True;
except
on E: Exception do Result := False;
end;
SL.Free;
end;
function TSmtpAgentMessageInformation.DeleteFile : Boolean;
begin
Result := True;
if FileExists(INI.MailQueuePath + FMailID + '.txt') then
Result := FileOperation(INI.MailQueuePath + FMailID + '.txt', '', 'DELETE');
end;
(******************************************************************************)
(* *)
(* STOP Smtp Agent Message Information *)
(* *)
(******************************************************************************)
end.