Indy/Lib/Core/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
  Classes,
  IdCommandHandlers,
  IdContext,
  IdIOHandler,
  IdReply,
  IdTCPServer,
  SysUtils;

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 Startup; override;
    procedure SetCommandHandlers(AValue: TIdCommandHandlers);
    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 SetCommandHandlers;
    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;
  FreeAndNil(FReplyUnknownCommand);
  FreeAndNil(FReplyTexts);
  FreeAndNil(FMaxConnectionReply);
  FreeAndNil(FHelpReply);
  FreeAndNil(FGreeting);
  FreeAndNil(FExceptionReply);
  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
  if CommandHandlers.PerformReplies then begin
    LReply := FReplyClass.CreateWithReplyTexts(nil, ReplyTexts); try
      LReply.Assign(ReplyUnknownCommand);
      LReply.Text.Add(ALine);
      AContext.Connection.IOHandler.Write(LReply.FormattedReply);
    finally
      FreeAndNil(LReply);
    end;
  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
        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.Startup;
var
  i, j: Integer;
  LDescr: TStrings;
  LHelpList: TStringList;
  LHandler, LAddedHandler: TIdCommandHandler;
begin
  inherited Startup;
  if 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
      LAddedHandler := CommandHandlers.Add;
      LAddedHandler.Command := 'Help'; {do not localize}
      LAddedHandler.Description.Text := 'Displays commands that the servers supports.'; {do not localize}
      LAddedHandler.NormalReply.Assign(HelpReply);
      LHelpList := TStringList.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
          LAddedHandler.Response.Add(LHelpList[i]);
          LDescr := TIdCommandHandler(LHelpList.Objects[i]).Description;
          for j := 0 to LDescr.Count - 1 do begin
            LAddedHandler.Response.Add('  ' + LDescr[j]); {do not localize}
          end;
          LAddedHandler.Response.Add(''); {do not localize}
        end;
      finally
        FreeAndNil(LHelpList);
      end;
    end;
  end;
end;

procedure TIdCmdTCPServer.SetCommandHandlers(AValue: TIdCommandHandlers);
begin
  FCommandHandlers.Assign(AValue);
end;

function TIdCmdTCPServer.CreateExceptionReply: TIdReply;
begin
  Result := FReplyClass.CreateWithReplyTexts(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.CreateWithReplyTexts(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.CreateWithReplyTexts(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.CreateWithReplyTexts(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.CreateWithReplyTexts(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) and FCommandHandlersInitialized then begin
    inherited CheckOkToBeActive;
  end;
end;

end.