www.pudn.com > indyprelim.zip > IdCmdTCPServer.pas
{
$Project$
$Workfile$
$Revision$
$DateUTC$
$Id$
This file is part of the Indy (Internet Direct) project, and is offered
under the dual-licensing agreement described on the Indy website.
(http://www.indyproject.org/)
Copyright:
(c) 1993-2005, Chad Z. Hower and the Indy Pit Crew. All rights reserved.
}
{
$Log$
}
{
Rev 1.42 2/1/05 12:36:36 AM RLebeau
Removed CommandHandlersEnabled property, no longer used
Rev 1.41 12/2/2004 9:26:42 PM JPMugaas
Bug fix.
Rev 1.40 2004.10.27 9:20:04 AM czhower
For TIdStrings
Rev 1.39 10/26/2004 8:42:58 PM JPMugaas
Should be more portable with new references to TIdStrings and TIdStringList.
Rev 1.38 6/21/04 10:07:14 PM RLebeau
Updated .DoConnect() to make sure the connection is still connected before
then sending the Greeting
Rev 1.37 6/20/2004 12:01:44 AM DSiders
Added "Do Not Localize" comments.
Rev 1.36 6/16/04 12:37:06 PM RLebeau
more compiler errors
Rev 1.35 6/16/04 12:30:32 PM RLebeau
compiler errors
Rev 1.34 6/16/04 12:12:26 PM RLebeau
Updated ExceptionReply, Greeting, HelpReply, MaxConnectionReply, and
ReplyUnknownCommand properties to use getter methods that call virtual Create
methods which descendants can override for class-specific initializations
Rev 1.33 5/16/04 5:16:52 PM RLebeau
Added setter methods to ExceptionReply, HelpReply, and ReplyTexts properties
Rev 1.32 4/19/2004 5:39:58 PM BGooijen
Added comment
Rev 1.31 4/18/2004 11:58:44 PM BGooijen
Wasn't thread safe
Rev 1.30 3/3/2004 4:59:38 AM JPMugaas
Updated for new properties.
Rev 1.29 2004.03.01 5:12:24 PM czhower
-Bug fix for shutdown of servers when connections still existed (AV)
-Implicit HELP support in CMDserver
-Several command handler bugs
-Additional command handler functionality.
Rev 1.28 2004.02.29 9:43:08 PM czhower
Added ReadCommandLine.
Rev 1.27 2004.02.29 8:17:18 PM czhower
Minor cosmetic changes to code.
Rev 1.26 2004.02.03 4:17:08 PM czhower
For unit name changes.
Rev 1.25 03/02/2004 01:49:22 CCostelloe
Added DoReplyUnknownCommand to allow TIdIMAP4Server set a correct reply for
unknown commands
Rev 1.24 1/29/04 9:43:16 PM RLebeau
Added setter methods to various TIdReply properties
Rev 1.23 2004.01.20 10:03:22 PM czhower
InitComponent
Rev 1.22 1/5/2004 2:35:36 PM JPMugaas
Removed of object in method declarations.
Rev 1.21 1/5/04 10:12:58 AM RLebeau
Fixed Typos in OnBeforeCommandHandler and OnAfterCommandHandler events
Rev 1.20 1/4/04 8:45:34 PM RLebeau
Added OnBeforeCommandHandler and OnAfterCommandHandler events
Rev 1.19 1/1/2004 9:33:22 PM BGooijen
the abstract class TIdReply was created sometimes, fixed that
Rev 1.18 2003.10.18 9:33:26 PM czhower
Boatload of bug fixes to command handlers.
Rev 1.17 2003.10.18 8:03:58 PM czhower
Defaults for codes
Rev 1.16 8/31/2003 11:49:40 AM BGooijen
removed FReplyClass, this was also in TIdTCPServer
Rev 1.15 7/9/2003 10:55:24 PM BGooijen
Restored all features
Rev 1.14 7/9/2003 04:36:08 PM JPMugaas
You now can override the TIdReply with your own type. This should illiminate
some warnings about some serious issues. TIdReply is ONLY a base class with
virtual methods.
Rev 1.13 2003.07.08 2:26:02 PM czhower
Sergio's update
Rev 1.0 7/7/2003 7:06:44 PM SPerry
Component that uses command handlers
Rev 1.0 7/6/2003 4:47:32 PM SPerry
Units that use Command handlers
Adapted to IdCommandHandlers.pas SPerry
Rev 1.7 4/4/2003 8:08:00 PM BGooijen
moved some consts from tidtcpserver here
Rev 1.6 3/23/2003 11:22:24 PM BGooijen
Moved some code to HandleCommand
Rev 1.5 3/22/2003 1:46:36 PM BGooijen
Removed unused variables
Rev 1.4 3/20/2003 12:18:30 PM BGooijen
Moved ReplyExceptionCode from TIdTCPServer to TIdCmdTCPServer
Rev 1.3 3/20/2003 12:14:18 PM BGooijen
Re-enabled Server.ReplyException
Rev 1.2 2/24/2003 07:21:50 PM JPMugaas
Now compiles with new core code restructures.
Rev 1.1 1/23/2003 11:06:10 AM BGooijen
Rev 1.0 1/20/2003 12:48:40 PM BGooijen
Tcpserver with command handlers, these were originally in TIdTcpServer, but
are now moved here
}
unit IdCmdTCPServer;
interface
{$I IdCompilerDefines.inc}
//Put FPC into Delphi mode
uses
IdCommandHandlers,
IdContext,
IdIOHandler,
IdReply,
IdSys,
IdTCPServer,
IdObjs;
type
TIdCmdTCPServer = class;
{ Events }
TIdCmdTCPServerAfterCommandHandlerEvent = procedure(ASender: TIdCmdTCPServer;
AContext: TIdContext) of object;
TIdCmdTCPServerBeforeCommandHandlerEvent = procedure(ASender: TIdCmdTCPServer;
var AData: string; AContext: TIdContext) of object;
TIdCmdTCPServer = class(TIdTCPServer)
protected
FCommandHandlers: TIdCommandHandlers;
FCommandHandlersInitialized: Boolean;
FExceptionReply: TIdReply;
FHelpReply: TIdReply;
FGreeting: TIdReply;
FMaxConnectionReply: TIdReply;
FOnAfterCommandHandler: TIdCmdTCPServerAfterCommandHandlerEvent;
FOnBeforeCommandHandler: TIdCmdTCPServerBeforeCommandHandlerEvent;
FReplyClass: TIdReplyClass;
FReplyTexts: TIdReplies;
FReplyUnknownCommand: TIdReply;
//
procedure CheckOkToBeActive; override;
function CreateExceptionReply: TIdReply; virtual;
function CreateGreeting: TIdReply; virtual;
function CreateHelpReply: TIdReply; virtual;
function CreateMaxConnectionReply: TIdReply; virtual;
function CreateReplyUnknownCommand: TIdReply; virtual;
procedure DoAfterCommandHandler(ASender: TIdCommandHandlers; AContext: TIdContext);
procedure DoBeforeCommandHandler(ASender: TIdCommandHandlers; var AData: string;
AContext: TIdContext);
procedure DoConnect(AContext: TIdContext); override;
function DoExecute(AContext: TIdContext): Boolean; override;
procedure DoMaxConnectionsExceeded(AIOHandler: TIdIOHandler); override;
// This is here to allow servers to override this functionality, such as IMAP4 server
procedure DoReplyUnknownCommand(AContext: TIdContext; ALine: string); virtual;
function GetExceptionReply: TIdReply;
function GetGreeting: TIdReply;
function GetHelpReply: TIdReply;
function GetMaxConnectionReply: TIdReply;
function GetRepliesClass: TIdRepliesClass; virtual;
function GetReplyClass: TIdReplyClass; virtual;
function GetReplyUnknownCommand: TIdReply;
procedure InitializeCommandHandlers; virtual;
procedure InitComponent; override;
// This is used by command handlers as the only input. This can be overriden to filter, modify,
// or preparse the input.
function ReadCommandLine(AContext: TIdContext): string; virtual;
procedure SetActive(AValue: Boolean); override;
procedure SetExceptionReply(AValue: TIdReply);
procedure SetGreeting(AValue: TIdReply);
procedure SetHelpReply(AValue: TIdReply);
procedure SetMaxConnectionReply(AValue: TIdReply);
procedure SetReplyUnknownCommand(AValue: TIdReply);
procedure SetReplyTexts(AValue: TIdReplies);
public
destructor Destroy; override;
published
property CommandHandlers: TIdCommandHandlers read FCommandHandlers
write FCommandHandlers;
property ExceptionReply: TIdReply read GetExceptionReply write SetExceptionReply;
property Greeting: TIdReply read GetGreeting write SetGreeting;
property HelpReply: TIdReply read GetHelpReply write SetHelpReply;
property MaxConnectionReply: TIdReply read GetMaxConnectionReply
write SetMaxConnectionReply;
property ReplyTexts: TIdReplies read FReplyTexts write SetReplyTexts;
property ReplyUnknownCommand: TIdReply read GetReplyUnknownCommand
write SetReplyUnknownCommand;
//
property OnAfterCommandHandler: TIdCmdTCPServerAfterCommandHandlerEvent
read FOnAfterCommandHandler write FOnAfterCommandHandler;
property OnBeforeCommandHandler: TIdCmdTCPServerBeforeCommandHandlerEvent
read FOnBeforeCommandHandler write FOnBeforeCommandHandler;
end;
implementation
uses
IdGlobal,
IdResourceStringsCore,
IdReplyRFC;
function TIdCmdTCPServer.GetReplyClass: TIdReplyClass;
begin
Result := TIdReplyRFC;
end;
function TIdCmdTCPServer.GetRepliesClass: TIdRepliesClass;
begin
Result := TIdRepliesRFC;
end;
destructor TIdCmdTCPServer.Destroy;
begin
inherited Destroy;
Sys.FreeAndNil(FReplyUnknownCommand);
Sys.FreeAndNil(FReplyTexts);
Sys.FreeAndNil(FMaxConnectionReply);
Sys.FreeAndNil(FHelpReply);
Sys.FreeAndNil(FGreeting);
Sys.FreeAndNil(FExceptionReply);
Sys.FreeAndNil(FCommandHandlers);
end;
procedure TIdCmdTCPServer.DoAfterCommandHandler(ASender: TIdCommandHandlers;
AContext: TIdContext);
begin
if Assigned(OnAfterCommandHandler) then begin
OnAfterCommandHandler(Self, AContext);
end;
end;
procedure TIdCmdTCPServer.DoBeforeCommandHandler(ASender: TIdCommandHandlers;
var AData: string; AContext: TIdContext);
begin
if Assigned(OnBeforeCommandHandler) then begin
OnBeforeCommandHandler(Self, AData, AContext);
end;
end;
function TIdCmdTCPServer.DoExecute(AContext: TIdContext): Boolean;
var
LLine: string;
begin
if CommandHandlers.Count > 0 then begin
Result := True;
if AContext.Connection.Connected then begin
LLine := ReadCommandLine(AContext);
// OLX sends blank lines during reset groups (NNTP) and expects no response.
// Not sure what the RFCs say about blank lines.
// I telnetted to some newsservers, and they dont respond to blank lines.
// This unit is core and not NNTP, but we should be consistent.
if LLine <> '' then begin
if not FCommandHandlers.HandleCommand(AContext, LLine) then begin
DoReplyUnknownCommand(AContext, LLine);
end;
end;
end;
end else begin
Result := inherited DoExecute(AContext);
end;
if Result and Assigned(AContext.Connection) then begin
Result := AContext.Connection.Connected;
end;
// the return value is used to determine if the DoExecute needs to be called again by the thread
end;
procedure TIdCmdTCPServer.DoReplyUnknownCommand(AContext: TIdContext; ALine: string);
var
LReply: TIdReply;
begin
LReply := FReplyClass.Create(nil, ReplyTexts); try
LReply.Assign(ReplyUnknownCommand);
LReply.Text.Add(ALine);
AContext.Connection.IOHandler.Write(LReply.FormattedReply);
finally
Sys.FreeAndNil(LReply);
end;
end;
procedure TIdCmdTCPServer.InitializeCommandHandlers;
begin
end;
procedure TIdCmdTCPServer.DoConnect(AContext: TIdContext);
var
LGreeting: TIdReply;
begin
inherited DoConnect(AContext);
// RLebeau - check the connection first in case the application
// chose to disconnect the connection in the OnConnect event handler.
if AContext.Connection.Connected then begin
if Greeting.ReplyExists then begin
ReplyTexts.UpdateText(Greeting);
LGreeting := FReplyClass.Create(nil); try // SendGreeting calls TIdReply.GetFormattedReply
LGreeting.Assign(Greeting); // and that changes the reply object, so we have to
SendGreeting(AContext, LGreeting); // clone it to make it thread-safe
finally
Sys.FreeAndNil(LGreeting);
end;
end;
end;
end;
procedure TIdCmdTCPServer.DoMaxConnectionsExceeded(AIOHandler: TIdIOHandler);
begin
inherited DoMaxConnectionsExceeded(AIOHandler);
//Do not UpdateText here - in thread. Is done in constructor
AIOHandler.Write(MaxConnectionReply.FormattedReply);
end;
procedure TIdCmdTCPServer.SetActive(AValue: Boolean);
var
i, j: Integer;
LDescr: TIdStrings;
LHelpList: TIdStringList;
LHandler: TIdCommandHandler;
begin
if (not IsDesignTime) and (not IsLoading)
and (not FActive) and (AValue) and (not FCommandHandlersInitialized) then begin
// InitializeCommandHandlers must be called only at runtime, and only after streaming
// has occured. This used to be in .Loaded and that worked for forms. It failed
// for dynamically created instances and also for descendant classes.
FCommandHandlersInitialized := True;
InitializeCommandHandlers;
if HelpReply.Code <> '' then begin
with CommandHandlers.Add do begin
Command := 'Help'; {do not localize}
Description.Text := 'Displays commands that the servers supports.'; {do not localize}
NormalReply.Assign(HelpReply);
LHelpList := TIdStringList.Create; try
for i := 0 to CommandHandlers.Count - 1 do begin
LHandler := CommandHandlers.Items[i];
if LHandler.HelpVisible then
begin
LHelpList.AddObject(LHandler.Command+LHandler.HelpSuperScript, LHandler);
end;
end;
LHelpList.Sort;
for i := 0 to LHelpList.Count - 1 do begin
Response.Add(LHelpList[i]);
LDescr := TIdCommandHandler(LHelpList.Objects[i]).Description;
for j := 0 to LDescr.Count - 1 do begin
Response.Add(' ' + LDescr[j]);
end;
Response.Add('');
end;
finally
Sys.FreeAndNil(LHelpList);
end;
end;
end;
end;
inherited SetActive(AValue);
end;
function TIdCmdTCPServer.CreateExceptionReply: TIdReply;
begin
Result := FReplyClass.Create(nil, ReplyTexts);
Result.SetReply(500, 'Unknown Internal Error'); {do not localize}
end;
function TIdCmdTCPServer.GetExceptionReply: TIdReply;
begin
if FExceptionReply = nil then begin
FExceptionReply := CreateExceptionReply;
end;
Result := FExceptionReply;
end;
procedure TIdCmdTCPServer.SetExceptionReply(AValue: TIdReply);
begin
ExceptionReply.Assign(AValue);
end;
function TIdCmdTCPServer.CreateGreeting: TIdReply;
begin
Result := FReplyClass.Create(nil, ReplyTexts);
Result.SetReply(200, 'Welcome'); {do not localize}
end;
function TIdCmdTCPServer.GetGreeting: TIdReply;
begin
if FGreeting = nil then begin
FGreeting := CreateGreeting;
end;
Result := FGreeting;
end;
procedure TIdCmdTCPServer.SetGreeting(AValue: TIdReply);
begin
Greeting.Assign(AValue);
end;
function TIdCmdTCPServer.CreateHelpReply: TIdReply;
begin
Result := FReplyClass.Create(nil, ReplyTexts);
Result.SetReply(100, 'Help follows'); {do not localize}
end;
function TIdCmdTCPServer.GetHelpReply: TIdReply;
begin
if FHelpReply = nil then begin
FHelpReply := CreateHelpReply;
end;
Result := FHelpReply;
end;
procedure TIdCmdTCPServer.SetHelpReply(AValue: TIdReply);
begin
HelpReply.Assign(AValue);
end;
function TIdCmdTCPServer.CreateMaxConnectionReply: TIdReply;
begin
Result := FReplyClass.Create(nil, ReplyTexts);
Result.SetReply(300, 'Too many connections. Try again later.'); {do not localize}
end;
function TIdCmdTCPServer.GetMaxConnectionReply: TIdReply;
begin
if FMaxConnectionReply = nil then begin
FMaxConnectionReply := CreateMaxConnectionReply;
end;
Result := FMaxConnectionReply;
end;
procedure TIdCmdTCPServer.SetMaxConnectionReply(AValue: TIdReply);
begin
MaxConnectionReply.Assign(AValue);
end;
function TIdCmdTCPServer.CreateReplyUnknownCommand: TIdReply;
begin
Result := FReplyClass.Create(nil, ReplyTexts);
Result.SetReply(400, 'Unknown Command'); {do not localize}
end;
function TIdCmdTCPServer.GetReplyUnknownCommand: TIdReply;
begin
if FReplyUnknownCommand = nil then begin
FReplyUnknownCommand := CreateReplyUnknownCommand;
end;
Result := FReplyUnknownCommand;
end;
procedure TIdCmdTCPServer.SetReplyUnknownCommand(AValue: TIdReply);
begin
ReplyUnknownCommand.Assign(AValue);
end;
procedure TIdCmdTCPServer.SetReplyTexts(AValue: TIdReplies);
begin
FReplyTexts.Assign(AValue);
end;
procedure TIdCmdTCPServer.InitComponent;
begin
inherited InitComponent;
FReplyClass := GetReplyClass;
// Before Command handlers as they need FReplyTexts, but after FReplyClass is set
FReplyTexts := GetRepliesClass.Create(Self, FReplyClass);
FCommandHandlers := TIdCommandHandlers.Create(Self, FReplyClass, ReplyTexts, ExceptionReply);
FCommandHandlers.OnAfterCommandHandler := DoAfterCommandHandler;
FCommandHandlers.OnBeforeCommandHandler := DoBeforeCommandHandler;
end;
function TIdCmdTCPServer.ReadCommandLine(AContext: TIdContext): string;
begin
Result := AContext.Connection.IOHandler.ReadLn;
end;
procedure TIdCmdTCPServer.CheckOkToBeActive;
begin
if CommandHandlers.Count = 0 then begin
inherited CheckOkToBeActive;
end;
end;
end.