www.pudn.com > EmailServer.zip > MailRouting.pas
unit MailRouting;
(******************************************************************************)
(* *)
(* SMTP Mail Routing Utilities *)
(* Part of Hermes SMTP/POP3 Server. *)
(* Copyright(C) 2000 by Alexander J. Fanti, All Rights Reserver Worldwide. *)
(* *)
(* Contains: TSmtpMessageInformation, TListServer, TDeliverMail *)
(* *)
(* Created January 18, 2000 by Alexander J. Fanti. See License.txt *)
(* *)
(* Depends on: DataU1 (TMailListInformation, routing) *)
(* Main (Posts a Windows Message to the form to tell it we need *)
(* some queue processing) *)
(* UtilU1 (Address (e-mail) formatting) *)
(* *)
(* Used by: SmtpServer *)
(* *)
(* Description: *)
(* TSmtpMessageInformation - An object used to manipulate a message coming in *)
(* from an SMTP connection to the Smtp Server. We *)
(* can manage the forward and reverse paths and *)
(* mail data with it. *)
(* TListServer - An object used to examine mail to a list to determine if it *)
(* should be distributed to the list, or interpreted as a *)
(* command. All commands are in the mail subject and preceeded *)
(* by a bang(!). The command must then follow with any *)
(* arguments. The mail body is ignored. *)
(* TDeliverMail - An object used to examine the To Routes of a mail message *)
(* and deliver the mail in the following way: 1) convert *)
(* alias to user, 2) Check user has forward (if so, rename to) *)
(* 3) If user local, deliver and drop to, 4) if user is list, *)
(* send to TListServer for further processing, 5) if user is *)
(* non-local, queue for agent processing. *)
(* *)
(* Revisions: 1/19/2000 AJF Added TDeliverMail, debugged and commented *)
(* 2/13/2000 AJF Added AccessControl data to *)
(* TSmtpMessageInformation to facilitate Smtp *)
(* Server Access control *)
(* *)
(******************************************************************************)
interface
uses Windows, Classes, SysUtils, INIFiles,
DataU1;
type
TSmtpMessageInformation = class(TObject)
private
FReverseRoute : TMessageRouteInformation;
FForwardRoute : TList;
FData : TStringList;
function GetForwardRouteCount : Longint;
function GetForwardRoute(Index : Longint) : TMessageRouteInformation;
function GetHeaderElement(Element : String) : String;
procedure SetHeaderElement(Element, Value : String);
function GetAddress(MailRoute : String) : String;
function GetRoute(MailAddress : String) : String;
public
// AccCtrl variables are used store information about the sender by the
// Smtp Server Connection about the transaction as the message comes in
AccCtrl_ToLocalUser : Boolean; // True if RCPT TO is to local domain
// and mailbox (user, alias, list)
AccCtrl_ToLocalCount : Longint; // Count of RCPT TOs that are to a
// local user
AccCtrl_FromLocalUser : Boolean; // MAIL FROM is a local user at a
// local domain
AccCtrl_FromLocalDomain : Boolean; // MAIL FROM is just from local
// domain
AccCtrl_FromAcceptedDomain : Boolean; // MAIL FROM is from an Accepted
// domain
AccCtrl_FromBannedDomain : Boolean; // MAIL FROM is from a Banned domain
AccCtrl_FromBannedMailbox : Boolean; // MAIL FROM is from a Banned Mailbox
AccCtrl_MessgaeSizeInBytes : Longint; // Size of message
constructor Create;
destructor Destroy; Override;
procedure Initialize;
procedure InsertReceived;
procedure AddSelfToReverseRoute;
procedure Data_AppendLine(Line : String);
property ReverseRoute : TMessageRouteInformation
read FReverseRoute write FReverseRoute;
property ForwardRoute[Index : Longint] : TMessageRouteInformation
read GetForwardRoute;
property ForwardRouteCount : Longint read GetForwardRouteCount;
function AddForwardRoute(Route : String) : Boolean;
procedure DeleteForwardRoute(Index : Longint);
procedure ClearForwardRoutes;
property Data : TStringList read FData;
function SaveToFile : Boolean; // Header in ###.ini, data in ###.txt
function LoadFromFile(MailID : String) : Boolean;
function GetHeader_Subject : String;
procedure SetHeader_Subject(Subject : String);
procedure GetHeader_From(var Address : String; var Route : String);
procedure SetHeader_From(EMailAddress : String);
procedure GetHeader_To(var Address : String; var Route : String);
procedure SetHeader_To(EMailAddress : String);
procedure GetHeader_ReplyTo(var Address : String; var Route : String);
procedure SetHeader_ReplyTo(EMailAddress : String);
end;
// Terminology Definition for this module.
// Address (ListAddress) refers to a user style email address
// such as username@domain.com
// Route (ListRoute) refers to a SMTP style email address
// such as <"username"@[IPAddress]|domain.com>
TListServer_StatusUpdate = procedure(Sender : TObject; Status : String;
Level : Integer) of Object;
TListServer = class(TObject)
private
FListName, FListAddress, FListRoute : String;
FMailList : TMailListInformation;
FMessageInfo : TSmtpMessageInformation;
FSenderAddress, FFromAddress : String; // email of sender (no <>)
FFromRoute : String;
FOnStatusUpdate : TListServer_StatusUpdate; // Event Ptr for StatusUpdate
procedure StatusUpdate(Status : String; Level : Integer); // Report Status
procedure ParseSubject(Subject : String; var Command : String;
var Parameter : String);
procedure BuildMessageToUser(MessageType, SenderAddress,
FailureMessage : String;
MagicNumber : Longint;
ExpirationDate : TDateTime);
procedure AddMessageToArchive;
public
constructor Create(ListName, ReversePath : String; Data : TStringList);
destructor Destroy; Override;
procedure Process;
property OnStatusUpdate : TListServer_StatusUpdate // Fired on Status
read FOnStatusUpdate write FOnStatusUpdate; // Update
end;
TDeliverMail_StatusUpdate = procedure(Sender : TObject; Status : String;
Level : Integer) of Object;
TDeliverMail = class(TObject)
private
FMessageInfo : TSmtpMessageInformation;
FOnStatusUpdate : TDeliverMail_StatusUpdate; // Event Ptr for StatusUpdate
procedure StatusUpdate(Status : String; Level : Integer); // Report Status
procedure ProcessAlias(var UserName : String; Domain : String);
procedure DeliverLocally(UserInfo : TPop3UserInformation);
procedure SendUndeliverableReply(DestinationPath : String);
public
constructor Create(MessageInfo : TSmtpMessageInformation);
destructor Destroy; Override;
procedure Deliver;
property OnStatusUpdate : TDeliverMail_StatusUpdate // Fired on Status
read FOnStatusUpdate write FOnStatusUpdate; // Update
end;
implementation
uses Main, {This is so we can call a "Trigger" of the
Smtp Agent Queue to get service.}
UtilU1;
(******************************************************************************)
(* *)
(* START Message Information Object *)
(* *)
(* This object is used for receiving and manipulating a message. *)
(* We accept data to it, set the Reverse-Path and add Forward-Paths. *)
(* We can also iterate throught the Forward-Paths and manipulate them or *)
(* remove them as we achieve delivery to each one. Then we save the *)
(* message, qeueing it for processing with the Smtp Agent. *)
(* *)
(******************************************************************************)
constructor TSmtpMessageInformation.Create;
begin
inherited Create;
FReverseRoute := TMessageRouteInformation.Create(mrte_From);
FForwardRoute := TList.Create;
FData := TStringList.Create;
Initialize;
end;
procedure TSmtpMessageInformation.ClearForwardRoutes;
var
x : Longint;
RouteInfo : TMessageRouteInformation;
begin
for x := FForwardRoute.Count -1 downto 0 do begin
RouteInfo := FForwardRoute[x];
FForwardRoute.Delete(x); // Remove from Forward-Path List
RouteInfo.Free; // Drop Forward-Path Object
end;
end;
destructor TSmtpMessageInformation.Destroy;
begin
FReverseRoute.Free; // Drop Reverse-Path Object
ClearForwardRoutes; // Drop each Forward-Path Object
FForwardRoute.Free; // Drop Forward-Path List
FData.Free; // Drop message data
inherited Destroy;
end;
procedure TSmtpMessageInformation.AddSelfToReverseRoute;
begin
// if the most recent Host in the Reverse Route isn't one of mine,
// then I add my ServerName to the start of the Hosts list of the
// Reverse-Path
if not INI.Domain_IsThisOneOfMine(FReverseRoute.Hosts[0]) then
FReverseRoute.Hosts.Insert(0, INI.ServerName);
end;
function TSmtpMessageInformation.GetForwardRouteCount : Longint;
begin
Result := FForwardRoute.Count;
end;
function TSmtpMessageInformation.GetForwardRoute(Index : Longint)
: TMessageRouteInformation;
begin
Result := nil;
if (Index >= 0) and (Index < FForwardRoute.Count) then
Result := FForwardRoute[Index];
end;
procedure TSmtpMessageInformation.Initialize;
begin
ClearForwardRoutes; // Drop each Forward-Path Object
FReverseRoute.Initialize; // Clear the Reverse-Path Object
FData.Clear; // Clear the message data
AccCtrl_ToLocalUser := False;
AccCtrl_ToLocalCount := 0;
AccCtrl_FromLocalUser := False;
AccCtrl_FromLocalDomain := False;
AccCtrl_FromAcceptedDomain := False;
AccCtrl_FromBannedDomain := False;
AccCtrl_FromBannedMailbox := False;
AccCtrl_MessgaeSizeInBytes := 0;
end;
procedure TSmtpMessageInformation.InsertReceived;
var
FromHost : String;
begin
// Here I insert a line into the top of the message data (presumably
// the message header). This line contains "Received" information
// in the format:
// Received: FROM [host] BY [ServerName] ; DD Mon YY HH:MM:SS Zone
//
// This should happen only once for any message, when it's received.
//
if FReverseRoute.Hosts.Count > 0 then FromHost := FReverseRoute.Hosts[0]
else FromHost := FReverseRoute.Domain;
FData.Insert(0, 'Received: FROM ' + FromHost + ' BY ' + INI.ServerName +
' ; ' + INI.TimeStamp);
end;
procedure TSmtpMessageInformation.Data_AppendLine(Line : String);
begin
FData.Add(Line); // Add this line to the end of the message data
end;
function TSmtpMessageInformation.AddForwardRoute(Route : String) : Boolean;
var
RouteInfo : TMessageRouteInformation;
x : Longint;
begin
// Given a string that specifies a route in the Smtp format
// <@HostA,@[#.#.#.#]:"mailbox"@HostC>
// Create a Forward-Path route and add it to the List of ForwardPaths
//
RouteInfo := TMessageRouteInformation.Create(mrte_To);
x := RouteInfo.ParseRoute(Route);
if x = 0 then begin
// If I successfullt parsed the route...
// Remove my domain(s) from top of the to route... it's reached me
while (RouteInfo.Hosts.Count > 0) and
(INI.Domain_IsThisOneOfMine(RouteInfo.Hosts[0])) do
RouteInfo.Hosts.Delete(0);
// Now add this route to the list of Forward Paths
FForwardRoute.Add(RouteInfo);
Result := True;
end else begin
// I did not successfully parse the route, so I need to free the route
// object instead of adding it to the list
RouteInfo.Free;
Result := False;
end;
end;
procedure TSmtpMessageInformation.DeleteForwardRoute(Index : Longint);
var
RouteInfo : TMessageRouteInformation;
begin
if (Index >= 0) and (Index < FForwardRoute.Count) then begin
RouteInfo := FForwardRoute[Index];
FForwardRoute.Delete(Index); // Remove from Forward-Path List
RouteInfo.Free; // Drop Forward-Path Object
end;
end;
function TSmtpMessageInformation.LoadFromFile(MailID : String) : Boolean;
var
SL : TStringList;
x, y : Longint;
tempStr : String;
RouteInfo : TMessageRouteInformation;
Found : Boolean;
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.ParseRoute(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...
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 begin
RouteInfo := TMessageRouteInformation.Create(mrte_To);
y := RouteInfo.ParseRoute(SL[x]);
if y = 0 then FForwardRoute.Add(RouteInfo)
else RouteInfo.Free;
end;
end;
Inc(x);
tempStr := Trim(SL[x]);
end;
end;
Found := True;
end else Inc(x);
end;
// We don't need to read the Retry information here...
// and we don't really... nut I write the code incase it's
// necessary in the future. Also note, this object's LoadFromFile
// and SaveToFile are nearly identicle to it's sister Object
// SmtpAgentMessageInformation which reads the same info from
// the same file, but stores it differently for the purposes
// of the Smtp Agent Object
// 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));
// := StringToInteger(tempStr, 0);
end;
if UpperCase(Copy(tempStr, 1, 10)) = 'REMAINING=' then begin
tempStr := Copy(tempStr, 11, Length(tempStr));
// := StringToInteger(tempStr, 0);
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;
Result := True;
end;
end;
end;
function TSmtpMessageInformation.SaveToFile : Boolean;
var
SL : TStringList;
FilenameOnly : String;
x : Longint;
RouteInfo : TMessageRouteInformation;
begin
FilenameOnly := GetUniqueFilename(INI.MailQueuePath);
Result := False;
SL := TStringList.Create;
SL.Add('[Reverse Path]');
SL.Add('From=' + FReverseRoute.BuildRoute);
SL.Add('');
SL.Add('[Forward Path]');
for x := 0 to FForwardRoute.Count -1 do begin
RouteInfo := FForwardRoute[x];
SL.Add('To=' + RouteInfo.BuildRoute);
end;
SL.Add('');
SL.Add('[Retry]');
SL.Add('Performed=' + IntToStr(0));
SL.Add('Remaining=' + IntToStr(INI.Smtp_Retries));
SL.Add('');
// Message data must always be last in file!
SL.Add('[Message]');
for x := 0 to FData.Count -1 do SL.Add(FData[x]);
try
SL.SaveToFile(INI.MailQueuePath + FilenameOnly + '.txt');
Result := True;
except
on E: Exception do Result := False;
end;
SL.Free;
end;
function TSmtpMessageInformation.GetHeaderElement(Element : String) : String;
// Assumes : seperates Element and Value and we don't specify colon
var
x, Len : Longint;
Found : Boolean;
begin
Result := '';
Len := Length(Element);
x := 0;
Found := False;
// Loop through data until we either 1) find out element,
// 2) run out of data, or
// 3) finish the header
while (not Found) and (x < FData.Count) and (FData[x] <> '') do begin
// I'll match an element regardless of case...
if LowerCase(Copy(Data[x], 1, Len +1)) = LowerCase(Element + ':') then begin
Result := Trim(Copy(Data[x], Len +2, Length(FData[x])));
Found := True;
end else Inc(x);
end;
end;
procedure TSmtpMessageInformation.SetHeaderElement(Element, Value : String);
// Assumes : seperates Element and Value and we don't specify colon
var
x, Len : Longint;
Found : Boolean;
begin
Len := Length(Element);
x := 0;
Found := False;
// Loop through data until we either 1) find out element,
// 2) run out of data, or
// 3) finish the header
while (not Found) and (x < FData.Count) and (FData[x] <> '') do begin
// Should I be case insensitive here?
if LowerCase(Copy(Data[x], 1, Len +1)) = LowerCase(Element + ':') then begin
// We found the element and must add the value
// to the name after the ": "
FData[x] := Copy(Data[x], 1, Len) + ': ' + Value;
Found := True;
end else Inc(x);
end;
if not Found then begin
// we did not find the element. we must add it to the header
FData.Insert(x, Element + ': ' + Value);
end;
end;
function TSmtpMessageInformation.GetHeader_Subject : String;
begin
Result := GetHeaderElement('Subject');
end;
procedure TSmtpMessageInformation.SetHeader_Subject(Subject : String);
begin
SetHeaderElement('Subject', Subject);
end;
function TSmtpMessageInformation.GetAddress(MailRoute : String) : String;
var
Route : TMessageRouteInformation;
begin
// Format a route or address string as an address
Result := MailRoute;
Route := TMessageRouteInformation.Create(mrte_Unknown);
if Route.ParseRoute(MailRoute) = 0 then
Result := Route.MailBox + '@' + Route.Domain;
Route.Free;
end;
function TSmtpMessageInformation.GetRoute(MailAddress : String) : String;
var
Route : TMessageRouteInformation;
begin
// Format a route or address string as a route
Result := MailAddress;
Route := TMessageRouteInformation.Create(mrte_Unknown);
if Route.ParseRoute(MailAddress) = 0 then
Result := Route.BuildRoute;
Route.Free;
end;
procedure TSmtpMessageInformation.GetHeader_From(var Address : String;
var Route : String);
var
tempStr : String;
begin
tempStr := GetHeaderElement('From');
Address := GetAddress(tempStr);
Route := GetRoute(tempStr);
end;
procedure TSmtpMessageInformation.SetHeader_From(EMailAddress : String);
begin
SetHeaderElement('From', GetRoute(EMailAddress));
end;
procedure TSmtpMessageInformation.GetHeader_To(var Address : String;
var Route : String);
var
tempStr : String;
begin
tempStr := GetHeaderElement('To');
Address := GetAddress(tempStr);
Route := GetRoute(tempStr);
end;
procedure TSmtpMessageInformation.SetHeader_To(EMailAddress : String);
begin
SetHeaderElement('To', GetRoute(EMailAddress));
end;
procedure TSmtpMessageInformation.GetHeader_ReplyTo(var Address : String;
var Route : String);
var
tempStr : String;
begin
tempStr := GetHeaderElement('Reply-To');
Address := GetAddress(tempStr);
Route := GetRoute(tempStr);
end;
procedure TSmtpMessageInformation.SetHeader_ReplyTo(EMailAddress : String);
begin
SetHeaderElement('Reply-To', GetRoute(EMailAddress));
end;
(******************************************************************************)
(* *)
(* STOP Message Information Object *)
(* *)
(******************************************************************************)
(******************************************************************************)
(* *)
(* START ListServer Object *)
(* *)
(* This object is used to process mail addressed to a local list. It *)
(* determines if the mail is a command to the list, and acts on that command, *)
(* generally performing an action to the list (sub, unsub, etc.) and sending *)
(* notification mail back to the original requestor. *)
(* If the mail is not a command, it is assumed to be a message for the list, *)
(* and is re-addressed for delivery to list members. It is then delivered *)
(* locally or queued by the Deliver Mail Object *)
(* *)
(******************************************************************************)
constructor TListServer.Create(ListName, ReversePath : String;
Data : TStringList);
var
x : Longint;
Member : PMailListMemberInfoRec;
Route : TMessageRouteInformation;
begin
inherited Create;
// Make copy of message to service.
// we'll have to change forward paths and data for list members
FMessageInfo := TSmtpMessageInformation.Create;
FMessageInfo.ReverseRoute.ParseRoute(ReversePath);
for x := 0 to Data.Count -1 do FMessageInfo.Data_AppendLine(Data[x]);
// Get List information (name, address and route)
FListName := ListName;
FListAddress := FListName + '@' + INI.ServerName;
Route := TMessageRouteInformation.Create(mrte_Unknown);
FListRoute := FListAddress;
if Route.ParseRoute(FListAddress) = 0 then FListRoute := Route.BuildRoute;
Route.Free;
// Open mailing list information
FMailList := TMailListInformation.Create;
FMailList.LoadFromFile(FListName);
// Fill To routes of message with list members addresses
for x := 0 to FMailList.MemberCount -1 do begin
Member := FMailList.Members[x];
if Member.Active then FMessageInfo.AddForwardRoute(Member.EMail);
end;
// Aquire Sender address and route from routing information
FSenderAddress := '';
FSenderAddress := FMessageInfo.ReverseRoute.Mailbox + '@' +
FMessageInfo.ReverseRoute.Domain;
FFromAddress := '';
FFromRoute := '';
FMessageInfo.GetHeader_From(FFromAddress, FFromRoute);
// Don't call Process here... then we couldn't set statusupdate first
end;
destructor TListServer.Destroy;
begin
FMessageInfo.Free;
FMailList.Free;
inherited Destroy;
end;
procedure TListServer.StatusUpdate(Status : String; Level : Integer);
begin
if Assigned(FOnStatusUpdate) then OnStatusUpdate(Self, Status, Level);
end;
procedure TListServer.AddMessageToArchive;
var
F : TextFile;
x : Longint;
begin
if (FMailList.ArchiveFile <> '') and (FMessageInfo.Data.Count > 0) then begin
AssignFile(F, FMailList.ArchiveFile);
try
Append(F);
for x := 0 to FMessageInfo.Data.Count -1 do
Writeln(F, FMessageInfo.Data[x]);
Writeln(F, '(------------------)');
except
on E: Exception do try
ReWrite(F);
for x := 0 to FMessageInfo.Data.Count -1 do
Writeln(F, FMessageInfo.Data[x]);
Writeln(F, '(------------------)');
except
on E: Exception do begin end;
end;
end;
CloseFile(F);
end;
end;
procedure TListServer.Process;
var
x : Longint;
Command, Parameter : String;
MailToProcess : Boolean; // True if there is mail that must be routed after
// we do our list server thing
MailForList : Boolean; // True if the mail we processed here goes to the
// list instead of a single list member
UserAddress : String; // This is the address to send list server replies.
// It's chosen by parameter to command, then from,
// then reversepath.
MagicNumber : Integer; // A random number that's a subscriber's "ID"
ExpirationDate : TDateTime; // Date and time when MagicNumber becomes invalid
Deleted : Boolean; // Have we removed a list member?
Accept : Boolean;
PendingMember : PMailListPendingMemberInfoRec;
Member : PMailListMemberInfoRec;
DeliverMail : TDeliverMail;
Route : TMessageRouteInformation;
begin
StatusUpdate('Processing Mail for List', STAT_PROCESSINGEVENT);
ParseSubject(FMessageInfo.GetHeader_Subject, Command, Parameter);
if Command <> '' then begin
MailToProcess := False;
MailForList := False;
StatusUpdate('Command: ' + Command + ' (' + Parameter + ')',
STAT_PROCESSINGEVENT);
// All commands require an action to the list, and
// A message sent back to the sender... UserAddress
// UserAddress is the following... Parameter (if supplied and is address),
// From Address, From Route Address.
UserAddress := Parameter;
if UserAddress = '' then UserAddress := FFromAddress;
if UserAddress = '' then UserAddress := FSenderAddress;
Route := TMessageRouteInformation.Create(mrte_From);
if Route.ParseRoute(UserAddress) = 0 then begin
if Command = 'SUBSCRIBE' then begin // I wanna subscribe
UserAddress := Parameter;
if UserAddress = '' then UserAddress := FFromAddress;
if UserAddress = '' then UserAddress := FSenderAddress;
if UserAddress <> '' then begin
if FMailList.LB_AllowPublicSubscription then begin
// Add to Pending Member List
MagicNumber := FMailList.PendingMember_NewMagicNumber;
ExpirationDate := Now + 1;
FMailList.PendingMemberAdd(ExpirationDate, MagicNumber,
UserAddress);
if FMailList.SaveToFile(FListName, False) then begin
StatusUpdate('Accepted, Needs confirmation. ' +
'Notification sent.', STAT_PROCESSINGEVENT);
BuildMessageToUser('Subscribe Success', UserAddress,
'FM', MagicNumber, ExpirationDate);
MailToProcess := True;
end else begin
StatusUpdate('List not accessible at this time. ' +
'Notification sent.', STAT_PROCESSINGERROR);
BuildMessageToUser('Subscribe Failure', UserAddress,
'List temporarily inaccessible',
MagicNumber, ExpirationDate);
MailToProcess := True;
end;
end else begin
StatusUpdate('List not open to public subscription. ' +
'Notification sent.', STAT_PROCESSINGERROR);
BuildMessageToUser('Subscribe Failure', UserAddress,
'List is closed to public subscription',
MagicNumber, ExpirationDate);
MailToProcess := True;
end;
end else begin
StatusUpdate('No EMail address supplied. ' +
'Notification cannot be sent.', STAT_PROCESSINGERROR);
end;
end;
end;
Route.Free;
if Command = 'CONFIRM SUBSCRIBE' then begin // they confirm sub
UserAddress := '';
if UserAddress = '' then UserAddress := FFromAddress;
if UserAddress = '' then UserAddress := FSenderAddress;
if UserAddress <> '' then begin
try // read magic number
MagicNumber := StrToInt(Parameter);
except
on E: Exception do MagicNumber := -1;
end;
if MagicNumber > -1 then begin
// Find Pending member by magic number
PendingMember
:= FMailList.PendingMember_FindByMagicNumber(MagicNumber);
if PendingMember <> nil then begin
if PendingMember.ExpirationDate >= Now then begin
// email match? do I need to check this? Should I?
if LowerCase(PendingMember.EMail) =
LowerCase(UserAddress) then begin
// Add to Members list
FMailList.MemberAdd(True, False, PendingMember.EMail);
if FMailList.SaveToFile(FListName, False) then begin
FMailList.PendingMemberDelete(PendingMember);
FMailList.SaveToFile(FListName, False);
// they're now on the list...
StatusUpdate('Subscribed. ' + 'Notification sent.',
STAT_PROCESSINGEVENT);
BuildMessageToUser('Subscribe Confirm Success',
PendingMember.EMail,
'FM', MagicNumber, ExpirationDate);
MailToProcess := True;
end else begin
StatusUpdate('List not accessible at this time. ' +
'Notification sent.', STAT_PROCESSINGERROR);
BuildMessageToUser('Subscribe Confirm Failure',
UserAddress, 'Unable to Subscribe - ' +
'List temporarily inaccessible',
MagicNumber, ExpirationDate);
MailToProcess := True;
end;
end else begin
StatusUpdate('The sender''s email address does not match! ' +
'Notification sent.', STAT_PROCESSINGERROR);
BuildMessageToUser('Subscribe Confirm Failure',
UserAddress, 'Your address (' +
UserAddress + ') does ' +
'not match the pending member''s address.',
MagicNumber, ExpirationDate);
MailToProcess := True;
end;
end else begin
StatusUpdate('Subscriber ID has expired. ' +
'Notification sent.', STAT_PROCESSINGERROR);
BuildMessageToUser('Subscribe Confirm Failure',
UserAddress,
'Your Subscriber ID number has expired',
MagicNumber, ExpirationDate);
MailToProcess := True;
// Remove expired entry
FMailList.PendingMemberDelete(PendingMember);
FMailList.SaveToFile(FListName, False);
end;
end else begin
StatusUpdate('Subscriber ID not found in pending. ' +
'Notification sent.', STAT_PROCESSINGERROR);
BuildMessageToUser('Subscribe Confirm Failure', UserAddress,
'I couldn''t find your Subscriber ID number ('
+ IntToStr(MagicNumber) + ')',
MagicNumber, ExpirationDate);
MailToProcess := True;
end;
end else begin
StatusUpdate('Subscriber ID missing. ' +
'Notification sent.', STAT_PROCESSINGERROR);
BuildMessageToUser('Subscribe Confirm Failure',
UserAddress,
'You didn''t supply a subscriber ID number',
MagicNumber, ExpirationDate);
MailToProcess := True;
end;
end else begin
StatusUpdate('No EMail address supplied. ' +
'Notification cannot be sent.', STAT_PROCESSINGERROR);
end;
end else
if Command = 'UNSUBSCRIBE' then begin
// remove me from this list
UserAddress := ''; // Parameter; NO Address parameter in unsubscribe...
if UserAddress = '' then UserAddress := FFromAddress;
if UserAddress = '' then UserAddress := FSenderAddress;
if UserAddress <> '' then begin
Deleted := False;
for x := FMailList.MemberCount -1 downto 0 do begin
Member := FMailList.Members[x];
// Should I be case sensitive here?
if LowerCase(Member.EMail) = LowerCase(UserAddress) then begin
FMailList.MemberDelete(x);
Deleted := True;
end;
end;
if Deleted and FMailList.SaveToFile(FListName, False) then begin
// Send them the farewell mail
StatusUpdate('Member removed from list. ' +
'Notification sent.', STAT_PROCESSINGEVENT);
BuildMessageToUser('Unsubscribe Success', UserAddress,
'FM', MagicNumber, ExpirationDate);
MailToProcess := True;
end else begin
if not Deleted then begin
StatusUpdate('Member not deleted. ' +
'Notification sent.', STAT_PROCESSINGERROR);
BuildMessageToUser('Unsubscribe Failure', UserAddress,
'Unable to Unsubscribe - ' +
'Member not found for delete.',
MagicNumber, ExpirationDate);
end else begin
StatusUpdate('List not accessible at this time. ' +
'Notification sent.', STAT_PROCESSINGERROR);
BuildMessageToUser('Unsubscribe Failure', UserAddress,
'Unable to Unsubscribe - ' +
'List temporarily inaccessible',
MagicNumber, ExpirationDate);
end;
MailToProcess := True;
end;
end else begin
StatusUpdate('No EMail address supplied. ' +
'Notification cannot be sent.', STAT_PROCESSINGERROR);
end;
end else
if Command = 'LIST' then begin // mail me a list of the members of list
UserAddress := '';
if UserAddress = '' then UserAddress := FFromAddress;
if UserAddress = '' then UserAddress := FSenderAddress;
if UserAddress <> '' then begin
if FMailList.LB_DoNotReportListMembers then begin
StatusUpdate('User requested restricted list membership. ' +
'Response sent.', STAT_PROCESSINGEVENT);
BuildMessageToUser('List Failure', UserAddress, 'FM', 0, Now);
MailToProcess := True;
end else begin
StatusUpdate('User requested list membership. ' +
'Response sent.', STAT_PROCESSINGEVENT);
BuildMessageToUser('List Success', UserAddress, 'FM', 0, Now);
MailToProcess := True;
end;
end else begin
StatusUpdate('No EMail address supplied. ' +
'List cannot be sent.', STAT_PROCESSINGERROR);
end;
end else
if Command = 'HELP' then begin // I want some help!
UserAddress := '';
if UserAddress = '' then UserAddress := FFromAddress;
if UserAddress = '' then UserAddress := FSenderAddress;
if UserAddress <> '' then begin
StatusUpdate('User requested "Help". ' +
'Response sent.', STAT_PROCESSINGEVENT);
BuildMessageToUser('Help', UserAddress, 'FM', 0, Now);
MailToProcess := True;
end else begin
StatusUpdate('No EMail address supplied. ' +
'Help cannot be sent.', STAT_PROCESSINGERROR);
end;
end else
begin
// Command unknown... better treat it as a message
StatusUpdate('List Command unknown... treating as mail to list.',
STAT_PROCESSINGERROR);
MailForList := True;
end;
end else MailForList := True;
if MailForList then begin
// Can we accept the submission?
Accept := True;
UserAddress := '';
if UserAddress = '' then UserAddress := FFromAddress;
if UserAddress = '' then UserAddress := FSenderAddress;
if FMailList.LB_MemberSubmissionOnly then begin
Accept := False;
// Is this UserAddress a list member ?
for x := 0 to FMailList.MemberCount -1 do begin
Member := FMailList.Members[x];
if LowerCase(Member.EMail) = LowerCase(UserAddress) then Accept := True;
end;
end;
if Accept then begin
MailToProcess := False;
// Edit the Reply-to if "Force replies to the List"
if FMailList.LB_ForceRepliesToList then begin
StatusUpdate('Forcing reply to list.', STAT_PROCESSINGEVENT);
FMessageInfo.SetHeader_ReplyTo(FListRoute);
end;
if FMailList.ArchiveFile <> '' then begin
StatusUpdate('Adding message to List Archive', STAT_PROCESSINGEVENT);
AddMessageToArchive;
end;
// Messages mailed to list members must be returned (on non-deliverable)
// to somebody in charge of the list... either the list's "MailErrorsTo"
// or the "listmaster" of the server
if FMailList.ErrorsMailedTo = '' then
FMessageInfo.ReverseRoute.ParseRoute('<' + FormatedAddress('listmaster',
INI.ServerName) + '>')
else
FMessageInfo.ReverseRoute.ParseRoute('<' + FMailList.ErrorsMailedTo +
'>');
DeliverMail := TDeliverMail.Create(FMessageInfo);
DeliverMail.OnStatusUpdate := FOnStatusUpdate;
DeliverMail.Deliver;
DeliverMail.Free;
end else begin
// we don't allow non-member submission to the list!
StatusUpdate('User cannot submit to the list. ' +
'They are not a member.', STAT_PROCESSINGERROR);
BuildMessageToUser('Submission Failure', UserAddress, 'FM', 0, Now);
MailToProcess := True;
end;
end;
if MailToProcess then begin
DeliverMail := TDeliverMail.Create(FMessageInfo);
DeliverMail.OnStatusUpdate := FOnStatusUpdate;
DeliverMail.Deliver;
DeliverMail.Free;
end;
StatusUpdate('Destination Mailing List Processed', STAT_PROCESSINGEVENT);
end;
procedure TListServer.ParseSubject(Subject : String;
var Command : String;
var Parameter : String);
begin
// We have a subject, we want to make sure it's a valid list command,
// and if so, break it into it's command and parameter constituents
Command := '';
Parameter := '';
// All commands to a list must start with a bang (!)
if Copy(Subject, 1, 1) = '!' then begin
Subject := Copy(Subject, 2, Length(Subject));
if UpperCase(Copy(Subject, 1, 9)) = 'SUBSCRIBE' then begin
Command := 'SUBSCRIBE';
Parameter := Trim(Copy(Subject, 10, Length(Subject)));
end else
if UpperCase(Copy(Subject, 1, 17)) = 'CONFIRM SUBSCRIBE' then begin
Command := 'CONFIRM SUBSCRIBE';
Parameter := Trim(Copy(Subject, 18, Length(Subject)));
end else
if UpperCase(Copy(Subject, 1, 11)) = 'UNSUBSCRIBE' then begin
Command := 'UNSUBSCRIBE';
Parameter := Trim(Copy(Subject, 12, Length(Subject)));
end else
if UpperCase(Copy(Subject, 1, 6)) = 'REMOVE' then begin
Command := 'UNSUBSCRIBE';
Parameter := Trim(Copy(Subject, 7, Length(Subject)));
end else
if UpperCase(Copy(Subject, 1, 4)) = 'LIST' then begin
Command := 'LIST';
Parameter := Trim(Copy(Subject, 5, Length(Subject)));
end else
if UpperCase(Copy(Subject, 1, 4)) = 'HELP' then begin
Command := 'HELP';
Parameter := Trim(Copy(Subject, 5, Length(Subject)));
end else begin
Command := '';
Parameter := '';
end;
end;
end;
procedure TListServer.BuildMessageToUser(MessageType, SenderAddress,
FailureMessage : String;
MagicNumber : Longint;
ExpirationDate : TDateTime);
var
x : Longint;
Route : TMessageRouteInformation;
SenderRoute : String; // Routes are <"x"@[y.z]>
Member : PMailListMemberInfoRec;
begin
// Generate the Sender's Route from the address
Route := TMessageRouteInformation.Create(mrte_Unknown);
SenderRoute := SenderAddress;
if Route.ParseRoute(SenderAddress) = 0 then SenderRoute := Route.BuildRoute;
Route.Free;
// Messages from the listserver don't have a return path.
// That's so routing failures are not sent back to us here.
FMessageInfo.ReverseRoute.ParseRoute('<>'); // no return path
FMessageInfo.ClearForwardRoutes;
FMessageInfo.AddForwardRoute(SenderRoute); // send to sender.
FMessageInfo.Data.Clear; // we'll fill in message below
MessageType := UpperCase(MessageType);
if MessageType = 'SUBMISSION FAILURE' then begin
FMessageInfo.Data.Add('Subject: ' + FListName + ' Submission Failure');
FMessageInfo.Data.Add('To: ' + SenderRoute);
FMessageInfo.Data.Add('From: ' + FListRoute);
FMessageInfo.Data.Add('');
FMessageInfo.Data.Add('The specified list either does not exist at this ');
FMessageInfo.Data.Add('server, or is not open to public submission.');
end else
if MessageType = 'SUBSCRIBE SUCCESS' then begin
FMessageInfo.Data.Add('Subject: ' + FListName + ' Subscription');
FMessageInfo.Data.Add('To: ' + SenderRoute);
FMessageInfo.Data.Add('From: ' + FListRoute);
FMessageInfo.Data.Add('');
FMessageInfo.Data.Add('You (' + SenderAddress + ') have been subscribed ' +
'to the');
FMessageInfo.Data.Add('"' + FListName + '" mailing list at ' +
INI.ServerName + '.');
FMessageInfo.Data.Add('');
FMessageInfo.Data.Add('To really join the list, you must send mail to: ' +
FListAddress);
FMessageInfo.Data.Add('With a subject of: !Confirm Subscribe ' +
IntToStr(MagicNumber));
FMessageInfo.Data.Add('By ' + TimeToStr(ExpirationDate) + ' on ' +
DateToStr(ExpirationDate));
FMessageInfo.Data.Add('');
FMessageInfo.Data.Add('In other words, to join the list, reply to this');
FMessageInfo.Data.Add('mail and paste the following line into your e-mail');
FMessageInfo.Data.Add('subject before you send it:');
FMessageInfo.Data.Add('!Confirm Subscribe ' + IntToStr(MagicNumber));
FMessageInfo.Data.Add('');
FMessageInfo.Data.Add('If you don''t want to subscribe, do nothing.');
end else
if MessageType = 'SUBSCRIBE FAILURE' then begin
FMessageInfo.Data.Add('Subject: ' + FListName + ' Subscription');
FMessageInfo.Data.Add('To: ' + SenderRoute);
FMessageInfo.Data.Add('From: ' + FListRoute);
FMessageInfo.Data.Add('');
FMessageInfo.Data.Add('Your subscription to ' + FListAddress +
' request failed because:');
FMessageInfo.Data.Add(FailureMessage);
end else
if MessageType = 'SUBSCRIBE CONFIRM SUCCESS' then begin
FMessageInfo.Data.Add('Subject: ' + FListName + ' Subscription Successful');
FMessageInfo.Data.Add('To: ' + SenderRoute);
FMessageInfo.Data.Add('From: ' + FListRoute);
FMessageInfo.Data.Add('');
FMessageInfo.Data.Add('To remove yourself, reply with a subject of ' +
'"!Remove" (no quotes)');
FMessageInfo.Data.Add('');
for x := 0 to FMailList.SL_Welcome.Count -1 do
FMessageInfo.Data.Add(FMailList.SL_Welcome[x]);
end else
if MessageType = 'SUBSCRIBE CONFIRM FAILURE' then begin
FMessageInfo.Data.Add('Subject: ' + FListName + ' Subscription');
FMessageInfo.Data.Add('To: ' + SenderRoute);
FMessageInfo.Data.Add('From: ' + FListRoute);
FMessageInfo.Data.Add('');
FMessageInfo.Data.Add('Your subscription confirmation to ' + FListAddress +
' failed because:');
FMessageInfo.Data.Add(FailureMessage);
end else
if MessageType = 'UNSUBSCRIBE SUCCESS' then begin
FMessageInfo.Data.Add('Subject: ' + FListName + ' Removal Successful');
FMessageInfo.Data.Add('To: ' + SenderRoute);
FMessageInfo.Data.Add('From: ' + FListRoute);
FMessageInfo.Data.Add('');
for x := 0 to FMailList.SL_Farewell.Count -1 do
FMessageInfo.Data.Add(FMailList.SL_Farewell[x]);
end else
if MessageType = 'UNSUBSCRIBE FAILURE' then begin
FMessageInfo.Data.Add('Subject: ' + FListName + ' Removal');
FMessageInfo.Data.Add('To: ' + SenderRoute);
FMessageInfo.Data.Add('From: ' + FListRoute);
FMessageInfo.Data.Add('');
FMessageInfo.Data.Add('Your removal from ' + FListAddress +
' failed because:');
FMessageInfo.Data.Add(FailureMessage);
end else
if MessageType = 'LIST SUCCESS' then begin
FMessageInfo.Data.Add('Subject: ' + FListName + ' Membership Listing');
FMessageInfo.Data.Add('To: ' + SenderRoute);
FMessageInfo.Data.Add('From: ' + FListRoute);
FMessageInfo.Data.Add('');
FMessageInfo.Data.Add('Members of "' + FListName + '" (' +
FListAddress +')');
FMessageInfo.Data.Add('');
for x := 0 to FMailList.MemberCount -1 do begin
Member := FMailList.Members[x];
if (Member.Active) and (not Member.Hidden) then
FMessageInfo.Data.Add(Member.EMail);
end;
end else
if MessageType = 'LIST FAILURE' then begin
FMessageInfo.Data.Add('Subject: ' + FListName + ' Membership Listing');
FMessageInfo.Data.Add('To: ' + SenderRoute);
FMessageInfo.Data.Add('From: ' + FListRoute);
FMessageInfo.Data.Add('');
FMessageInfo.Data.Add('Membership of "' + FListName + '" (' +
FListAddress +') is restricted.');
end else
if MessageType = 'HELP' then begin
FMessageInfo.Data.Add('Subject: ' + FListName + ' Help');
FMessageInfo.Data.Add('To: ' + SenderRoute);
FMessageInfo.Data.Add('From: ' + FListRoute);
FMessageInfo.Data.Add('');
FMessageInfo.Data.Add('Hermes SMTP/POP3 Server Mail List Help');
FMessageInfo.Data.Add('');
FMessageInfo.Data.Add('Send list commands in the subject of your email.');
FMessageInfo.Data.Add('The following commands are valid:');
FMessageInfo.Data.Add(' Subscribe, Confirm Subscribe,');
FMessageInfo.Data.Add(' Unsubscribe, Remove, List, Help');
FMessageInfo.Data.Add('');
FMessageInfo.Data.Add('Command Syntax:');
FMessageInfo.Data.Add('');
FMessageInfo.Data.Add(' !Subscribe [Address]');
FMessageInfo.Data.Add(' !Confirm Subscribe [Number]');
FMessageInfo.Data.Add(' !Unsubscribe');
FMessageInfo.Data.Add(' !Remove');
FMessageInfo.Data.Add(' !List');
FMessageInfo.Data.Add(' !Help');
FMessageInfo.Data.Add('');
FMessageInfo.Data.Add('Replace [Address] with your full e-mail address.');
FMessageInfo.Data.Add('Replace [Number] with the number you were sent ' +
'in the subscription reply.');
FMessageInfo.Data.Add('');
end;
end;
(******************************************************************************)
(* *)
(* STOP ListServer Object *)
(* *)
(******************************************************************************)
(******************************************************************************)
(* *)
(* START Deliver Mail Object *)
(* *)
(* This object is used to route mail locally. It's employed by the *)
(* Smtp Server to determine if mail should be processed as a message to a *)
(* list, delivered locally, or queued for processing by the Smtp Agent. *)
(* ALL mail bound for non-local users must be queued and processed by the *)
(* *)
(******************************************************************************)
constructor TDeliverMail.Create(MessageInfo : TSmtpMessageInformation);
begin
inherited Create;
// FMessageInfo was created somewhere else and will be freed by whatever
// created it. We are using this as a link to that object
FMessageInfo := MessageInfo;
// don't call Deliver here... then we couldn't set statusupdate
end;
procedure TDeliverMail.StatusUpdate(Status : String; Level : Integer);
begin
if Assigned(FOnStatusUpdate) then OnStatusUpdate(Self, Status, Level);
end;
destructor TDeliverMail.Destroy;
begin
// Do NOT free FMessageInfo... it was not created here, and will be freed
// by whatever created it!
inherited Destroy;
end;
procedure TDeliverMail.ProcessAlias(var UserName : String; Domain : String);
// Accepts a user name... determines if it's an alias and returns the real
// user name...
var
MailBox, AliasID, AliasUser : String;
begin
// First, try to fine an Alias qualified with a domain...
Mailbox := UserName + '@' + Domain;
if INI.Alias_Exists(MailBox) then begin // The Mailbox is an alias
UserName := INI.Alias_Find(MailBox); // The alias is...
INI.Alias_Parse(UserName, AliasID, AliasUser); // we seperate it to get
// the user ID
UserName := AliasUser; // and return the user ID here
StatusUpdate('Destination (' + Mailbox + ') is Alias for ' + UserName,
STAT_PROCESSINGEVENT);
end else begin
// If we could not find a fully qualified Alias,
// then let's look for an unqualified one...
MailBox := UserName;
if INI.Alias_Exists(MailBox) then begin // The Mailbox is an alias
UserName := INI.Alias_Find(MailBox); // The alias is...
INI.Alias_Parse(UserName, AliasID, AliasUser); // we seperate it to get
// the user ID
UserName := AliasUser; // and return the user ID here
StatusUpdate('Destination (' + Mailbox + ') is Alias for ' + UserName,
STAT_PROCESSINGEVENT);
end;
end;
end;
procedure TDeliverMail.DeliverLocally(UserInfo : TPop3UserInformation);
// Deliver a copy of the message to a local user.
var
x : Longint;
SL : TStringList; // Copy of the mail data for the user (has specail
// data individual to each user (return path)
begin
if Assigned(UserInfo) then begin
SL := TStringList.Create;
// Add the Return Route
StatusUpdate('Adding Return Path to Message Header', STAT_PROCESSINGEVENT);
SL.Add('Return-Path: ' + FMessageInfo.ReverseRoute.BuildRoute);
// Add the remaining mail data
for x := 0 to FMessageInfo.Data.Count -1 do SL.Add(FMessageInfo.Data[x]);
// Save the mail to the user
StatusUpdate('Saving Message to User', STAT_PROCESSINGEVENT);
UserInfo.SaveMail(SL);
SL.Free;
end;
end;
procedure TDeliverMail.Deliver;
var
MailBox : String;
ToRouteIndex : Longint; // The Index to the ToRouteArray
// we are currently trying to deliver
ToRouteInfo : TMessageRouteInformation; // The ToRoute we are currently
// trying to deliver to...
UserInfo : TPop3UserInformation; // If ToRoute is a local user, we'll
// need to know about them to make
// the delivery
ListServ : TListServer; // If ToRoute proves to be a list,
// we'll need a ListServer object
// for further processing
begin
StatusUpdate('Processing Destination Route(s)', STAT_PROCESSINGEVENT);
ToRouteIndex := 0;
while ToRouteIndex < FMessageInfo.ForwardRouteCount do begin
ToRouteInfo := FMessageInfo.ForwardRoute[ToRouteIndex];
// Question, should we short-circuit the routing if we're the
// Destination host, and there are additional hosts in the forward path ?
// I'll say yes. Let's hope this is cool.
if INI.Domain_IsThisOneOfMine(ToRouteInfo.Domain) then begin
// This belongs to me, let's see if we can find a user, alias or list
// for it...
StatusUpdate('Destination Route is Local', STAT_PROCESSINGEVENT);
MailBox := ToRouteInfo.Mailbox;
ProcessAlias(MailBox, ToRouteInfo.Domain); // if alias, get real user mailbox
if INI.User_Exists(MailBox) then begin
StatusUpdate('Destination is User', STAT_PROCESSINGEVENT);
// We need to deliver the message to the user...
UserInfo := TPop3UserInformation.Create;
UserInfo.LoadFromFile(MailBox);
if UserInfo.ForwardToAddress = '' then begin
// The local user has no forward... we can deliver to the local user
DeliverLocally(UserInfo);
// Remove this To line, it's been successfully processed
StatusUpdate('Removing Destination Route. Delivered.',
STAT_PROCESSINGEVENT);
FMessageInfo.DeleteForwardRoute(ToRouteIndex);
end else begin
// the local user has a forward.
// we need to process it just like it were the original
StatusUpdate('Forwarding...', STAT_PROCESSINGEVENT);
// replace the to route with the new (forward) one
if ToRouteInfo.ParseRoute(UserInfo.ForwardToAddress) = 0 then begin
// I'm trying the forward address...
// Here I re-start delivery process again.
// I could have made this a function I call, but then I'm
// affraid of the possibility of recursive calling...
// for example... user A forwards to B who forwards back to A
// For that reason, I'll only process one forward here.
// is it local (domain), is it alias? is it user?
if INI.Domain_IsThisOneOfMine(ToRouteInfo.Domain) then begin
StatusUpdate('Destination Route is Local', STAT_PROCESSINGEVENT);
MailBox := ToRouteInfo.Mailbox;
ProcessAlias(MailBox, ToRouteInfo.Domain); // if alias, get real user mailbox
if INI.User_Exists(MailBox) then begin
StatusUpdate('Destination is User', STAT_PROCESSINGEVENT);
// We need to deliver the message to the user...
UserInfo := TPop3UserInformation.Create;
// we won't check for forward or mail list...
// we're not allowing user to forward indefinately or
// forward to a list.
DeliverLocally(UserInfo);
// Remove this To line, it's been successfully processed
StatusUpdate('Removing Destination Route. Delivered.',
STAT_PROCESSINGEVENT);
FMessageInfo.DeleteForwardRoute(ToRouteIndex);
end else begin
StatusUpdate('Destination Route Local, but no user ' +
'available... Deleting ' + ToRouteInfo.BuildRoute,
STAT_PROCESSINGERROR);
FMessageInfo.DeleteForwardRoute(ToRouteIndex);
end;
end else begin
StatusUpdate('Destination Route Not Local... ' +
'Queueing for Agent...', STAT_PROCESSINGEVENT);
Inc(ToRouteIndex);
end;
end else begin
// Unable to forward... route is bad... better deliver locally
StatusUpdate('Unable to understand forward address... ' +
'Delivered Locally.', STAT_PROCESSINGERROR);
DeliverLocally(UserInfo);
// Remove this To line, it's been successfully processed
StatusUpdate('Removing Destination Route. Delivered.',
STAT_PROCESSINGEVENT);
FMessageInfo.DeleteForwardRoute(ToRouteIndex);
end;
end;
UserInfo.Free;
end else
if INI.List_Exists(ToRouteInfo.Mailbox) then begin
StatusUpdate('Destination Route is a Mailing List',
STAT_PROCESSINGEVENT);
// It's a mailing list that requires specail processing,
// including exploding the list and generating messages
ListServ := TListServer.Create(ToRouteInfo.Mailbox,
FMessageInfo.ReverseRoute.BuildRoute,
FMessageInfo.Data);
ListServ.OnStatusUpdate := FOnStatusUpdate;
ListServ.Process;
ListServ.Free;
// Remove this To line, it's been successfully processed
StatusUpdate('Removing Destination Route. Delivered.',
STAT_PROCESSINGEVENT);
FMessageInfo.DeleteForwardRoute(ToRouteIndex);
end else
begin
// This is supposed to be local, but I don't have anywhere to deliver
// it. I checked for this in the RCPT, but I must have messed up to
// get here.
// I guess I'll have to generate a "Failure Notification" and queue
// that for Agent processing which will send that back to the sender
SendUndeliverableReply(ToRouteInfo.BuildRoute);
StatusUpdate('Destination Route Local, but no user available... ' +
'Generating "Undeliverable" Notification',
STAT_PROCESSINGERROR);
FMessageInfo.DeleteForwardRoute(ToRouteIndex);
end;
end else begin
// foreign domain... don't do anything more here
// The SMTP Agent will try to send this on to the next host...
// just move on to the next To Route
StatusUpdate('Destination Route Not Local... queueing for Agent...',
STAT_PROCESSINGEVENT);
Inc(ToRouteIndex);
end;
end;
// Save remaining routing info and message (if there is any)
if FMessageInfo.ForwardRouteCount > 0 then begin
FMessageInfo.SaveToFile; // written to FQueuePath as XXX.ini and XXX.txt
// Notify the Server (Main Form) that we've added
// a message to the Agent Queue and that it needs attention
if INI.Agent_ServiceQueueImmediately then Trigger_ServiceSMTPQueue;
StatusUpdate(IntToStr(FMessageInfo.ForwardRouteCount) +
' Destination Route(s) Queued for Agent Processing',
STAT_PROCESSINGEVENT);
end;
StatusUpdate('Incoming Mail Processed', STAT_PROCESSINGEVENT);
end;
procedure TDeliverMail.SendUndeliverableReply(DestinationPath : String);
var
MessageInfo : TSmtpMessageInformation;
Route : TMessageRouteInformation;
x : Longint;
begin
MessageInfo := TSmtpMessageInformation.Create;
// Set the routes...
MessageInfo.ReverseRoute.ParseRoute('<>'); // No return for failure notice
MessageInfo.AddForwardRoute(FMessageInfo.ReverseRoute.BuildRoute);
// 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('');
MessageInfo.Data_AppendLine(DestinationPath);
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 Route.BuildRoute <> '<>' then MessageInfo.SaveToFile;
end;
MessageInfo.Free;
end;
(******************************************************************************)
(* *)
(* STOP Deliver Mail Object *)
(* *)
(******************************************************************************)
end.