cltcpserver.pas

Clever_Internet_Suite_6.2的代码 Clever_Internet_Suite_6.2的代码 Clever_Internet_Suite_6.2的代码

{
  Clever Internet Suite Version 6.2
  Copyright (C) 1999 - 2006 Clever Components
  www.CleverComponents.com
}

unit clTcpServer;

interface

{$I clVer.inc}
{$IFDEF DELPHI7}
  {$WARN UNSAFE_CODE OFF}
  {$WARN UNSAFE_TYPE OFF}
  {$WARN UNSAFE_CAST OFF}
{$ENDIF}

uses
  Classes, SysUtils, Windows, WinSock, Messages, clWinSock2, clThreadPool, clSocket, clCert,
  SyncObjs, clSspi;

type
  TclServerTlsMode = (stNone, stImplicit, stExplicitAllow, stExplicitRequire);

  TclServerSaslFlag = (ssUseLogin, ssUseCramMD5, ssUseNTLM);
  TclServerSaslFlags = set of TclServerSaslFlag;

  TclTcpServer = class;

  TclCommandConnection = class(TclAsyncConnection)
  private
    FAccessor: TCriticalSection;
    FWriteStream: TStream;
    FLines: TStrings;
    FCurrentLine: Integer;
    FLinesTrailer: string;
    FUseDotTerminator: Boolean;
    FData: Pointer;
    FCommandRaw: string;
    FIsReading: Boolean;
    procedure SetLines(const Value: TStrings);
    function GetIsTls: Boolean;
  protected
    procedure DoDestroy; override;
  public
    constructor Create;
    procedure WriteData(AData: TStream); override;
    procedure WriteString(const AString: string);
    procedure BeginWork;
    procedure EndWork;
    property Data: Pointer read FData write FData;
    property IsTls: Boolean read GetIsTls;
  end;

  TclServerThread = class(TThread)
  private
    FStopEvent: THandle;
    FStartedEvent: THandle;
    FConnections: TList;
    FWindowHandle: HWND;
    FServerSocket: TSocket;
    FServer: TclTcpServer;
    procedure DispatchMessages;
    procedure WndProc(var Message: TMessage);
    procedure ClearConnections;
    procedure OpenServerSocket;
    procedure CloseServerSocket;
    procedure AcceptConnection;
    procedure ReadConnection(AConnection: TclCommandConnection);
    procedure WriteConnection(AConnection: TclCommandConnection);
    procedure CloseConnection(AConnection: TclCommandConnection);
    function FindConnection(ASocket: TSocket): TclCommandConnection;
    procedure AcceptConnectionDone(Sender: TObject);
  protected
    procedure Execute; override;
  public
    constructor Create(AServer: TclTcpServer);
    procedure Start;
    procedure Stop;
  end;

  TclServerErrorEvent = procedure (Sender: TObject; E: Exception) of object;

  TclConnectionEvent = procedure (Sender: TObject; AConnection: TclCommandConnection) of object;
  TclCreateConnectionEvent = procedure (Sender: TObject; var AConnection: TclCommandConnection) of object;
  TclConnectionDataEvent = procedure (Sender: TObject; AConnection: TclCommandConnection; AData: TStream) of object;
  TclVerifyClientEvent = procedure (Sender: TObject; AConnection: TclCommandConnection;
    ACertificate: TclCertificate; const AStatusText: string; AStatusCode: Integer; var AVerified: Boolean) of object;

  TclTcpServer = class(TComponent)
  private
    FPort: Integer;
    FServerThread: TclServerThread;
    FTimeOut: Integer;
    FBatchSize: Integer;
    FWorkerThreadPool: TclThreadPool;
    FServerName: string;
    FUseTLS: TclServerTlsMode;
    FBitsPerSec: Integer;
    FIsStart: Boolean;
    FStartError: string;
    FStartErrorCode: Integer;
    FOnStart: TNotifyEvent;
    FOnStop: TNotifyEvent;
    FOnServerError: TclServerErrorEvent;
    FOnAcceptConnection: TclConnectionEvent;
    FOnCloseConnection: TclConnectionEvent;
    FOnGetCertificate: TclOnGetCertificateEvent;
    FOnCreateConnection: TclCreateConnectionEvent;
    FTLSFlags: TclTlsFlags;
    FRequireClientCertificate: Boolean;
    FOnVerifyClient: TclVerifyClientEvent;
    procedure ReadConnection(AConnection: TclCommandConnection);
    procedure WriteConnection(AConnection: TclCommandConnection);
    function GetMaxThreadCount: Integer;
    function GetMinThreadCount: Integer;
    procedure SetMaxThreadCount(const Value: Integer);
    procedure SetMinThreadCount(const Value: Integer);
    function GetConnection(Index: Integer): TclCommandConnection;
    function GetConnectionCount: Integer;
    procedure ServerError(E: Exception);
    procedure InternalStop;
  protected
    procedure GetCertificate(Sender: TObject; var ACertificate: TclCertificate; var Handled: Boolean);
    procedure VerifyClient(Sender: TObject; ACertificate: TclCertificate;
      const AStatusText: string; AStatusCode: Integer; var AVerified: Boolean);
    procedure DoServerError(E: Exception); virtual;
    procedure DoCreateConnection(var AConnection: TclCommandConnection); virtual;
    procedure DoAcceptConnection(AConnection: TclCommandConnection); virtual;
    procedure DoCloseConnection(AConnection: TclCommandConnection); virtual;
    procedure DoReadConnection(AConnection: TclCommandConnection; AData: TStream); virtual;
    procedure DoWriteConnection(AConnection: TclCommandConnection); virtual;
    procedure DoStart; virtual;
    procedure DoStop; virtual;
    procedure DoGetCertificate(var ACertificate: TclCertificate; var Handled: Boolean); virtual;
    procedure DoVerifyClient(AConnection: TclCommandConnection;
      ACertificate: TclCertificate; const AStatusText: string;
      AStatusCode: Integer; var AVerified: Boolean); virtual;
    function CreateConnection: TclCommandConnection;
    function CreateDefaultConnection: TclCommandConnection; virtual; abstract;
    procedure CloseConnection(AConnection: TclCommandConnection);
    procedure DoDestroy; virtual;
    procedure SetUseTLS(const Value: TclServerTlsMode); virtual;
    procedure StartTls(AConnection: TclCommandConnection);
    property Connections[Index: Integer]: TclCommandConnection read GetConnection;
    property ConnectionCount: Integer read GetConnectionCount;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Start;
    procedure Stop;
  published
    property ServerName: string read FServerName write FServerName;
    property Port: Integer read FPort write FPort;
    property TimeOut: Integer read FTimeOut write FTimeOut default 60000;
    property BatchSize: Integer read FBatchSize write FBatchSize default 8192;
    property MinThreadCount: Integer read GetMinThreadCount write SetMinThreadCount default 1;
    property MaxThreadCount: Integer read GetMaxThreadCount write SetMaxThreadCount default 5;
    property UseTLS: TclServerTlsMode read FUseTLS write SetUseTLS default stNone;
    property TLSFlags: TclTlsFlags read FTLSFlags write FTLSFlags default [tfUseTLS];
    property BitsPerSec: Integer read FBitsPerSec write FBitsPerSec default 0;
    property RequireClientCertificate: Boolean read FRequireClientCertificate
      write FRequireClientCertificate default False;
    property OnStart: TNotifyEvent read FOnStart write FOnStart;
    property OnStop: TNotifyEvent read FOnStop write FOnStop;
    property OnServerError: TclServerErrorEvent read FOnServerError write FOnServerError;
    property OnCreateConnection: TclCreateConnectionEvent read FOnCreateConnection write FOnCreateConnection;
    property OnAcceptConnection: TclConnectionEvent read FOnAcceptConnection write FOnAcceptConnection;
    property OnCloseConnection: TclConnectionEvent read FOnCloseConnection write FOnCloseConnection;
    property OnGetCertificate: TclOnGetCertificateEvent read FOnGetCertificate write FOnGetCertificate;
    property OnVerifyClient: TclVerifyClientEvent read FOnVerifyClient write FOnVerifyClient;
  end;

  TclTcpCommandParams = class
  private
    FCommand: string;
    FParams: string;
  public
    property Command: string read FCommand write FCommand;
    property Params: string read FParams write FParams;
  end;
  
  TclTcpCommandInfo = class
  private
    FName: string;
  protected
    procedure Execute(AConnection: TclCommandConnection; AParams: TclTcpCommandParams); virtual; abstract;
  public
    property Name: string read FName write FName;
  end;

  EclTcpCommandError = class(EclSocketError)
  private
    FCommand: string;
  public
    constructor Create(const ACommand, AErrorMsg: string; AErrorCode: Integer);
    property Command: string read FCommand;
  end;

  TclCommandConnectionEvent = procedure (Sender: TObject; AConnection: TclCommandConnection;
    const ACommand, AText: string) of object;

  TclTcpCommandServer = class(TclTcpServer)
  private
    FCommands: TList;
    FOnReceiveCommand: TclCommandConnectionEvent;
    FOnSendResponse: TclCommandConnectionEvent;
    procedure ClearCommands;
  protected
    procedure AddCommand(AInfo: TclTcpCommandInfo);
    function GetCommand(const AName: string): TclTcpCommandInfo;
    procedure SendResponse(AConnection: TclCommandConnection;
      const ACommand, AResponse: string); overload;
    procedure SendResponse(AConnection: TclCommandConnection;
      const ACommand, AResponse: string; const Args: array of const); overload;
    procedure DoReceiveCommand(AConnection: TclCommandConnection;
      const ACommand, AParams: string); virtual;
    procedure DoSendResponse(AConnection: TclCommandConnection;
      const ACommand, AResponse: string); virtual;
    procedure RegisterCommands; virtual; abstract;
    function GetNullCommand(const ACommand: string): TclTcpCommandInfo; virtual; abstract;
    function GetCommandParams(const AData: string): TclTcpCommandParams; virtual;
    procedure ProcessData(AConnection: TclCommandConnection; const AData: string); virtual;
    procedure ProcessCommand(AConnection: TclCommandConnection;
      AInfo: TclTcpCommandInfo; AParams: TclTcpCommandParams);
    procedure ProcessUnhandledError(AConnection: TclCommandConnection;
      AParams: TclTcpCommandParams; E: Exception); virtual;
    procedure DoProcessCommand(AConnection: TclCommandConnection;
      AInfo: TclTcpCommandInfo; AParams: TclTcpCommandParams); virtual;
    procedure DoReadConnection(AConnection: TclCommandConnection; AData: TStream); override;
    procedure DoWriteConnection(AConnection: TclCommandConnection); override;
    procedure DoDestroy; override;
    procedure AddMultipleLines(AConnection: TclCommandConnection; ALines: TStrings);
    procedure SendMultipleLines(AConnection: TclCommandConnection;
      const ALinesTrailer: string; AUseDotTerminator: Boolean);
    function CheckForEndOfData(const AData: string): Boolean;
  public
    constructor Create(AOwner: TComponent); override;
  published
    property OnReceiveCommand: TclCommandConnectionEvent read FOnReceiveCommand write FOnReceiveCommand;
    property OnSendResponse: TclCommandConnectionEvent read FOnSendResponse write FOnSendResponse;
  end;

resourcestring
  cServerStarted = 'The server is already started';
  cStartError = 'An unknown error occured during starting the server';

implementation

uses
  clTlsSocket{$IFDEF DEMO}, clEncoder{$ENDIF}, clUtils{$IFNDEF DELPHI6},
  Forms{$ENDIF}{$IFDEF LOGGER}, clLogger{$ENDIF};

const
  CL_SOCKETEVENT = WM_USER + 2110;
      
{ TclTcpServer }

constructor TclTcpServer.Create(AOwner: TComponent);
var
  wsaData: TWSAData;
  res: Integer;
begin
  inherited Create(AOwner);
  res := WSAStartup($202, wsaData);
  if (res <> 0) then
  begin
    RaiseSocketError(WSAGetLastError());
  end;
  FWorkerThreadPool := TclThreadPool.Create();

  MinThreadCount := 1;
  MaxThreadCount := 5;

  FTimeOut := 60000;
  FBatchSize := 8192;
  FUseTLS := stNone;
  FTLSFlags := [tfUseTLS];
  FRequireClientCertificate := False;
end;

destructor TclTcpServer.Destroy;
begin
  Stop();
  DoDestroy();
  WSACleanup();
  inherited Destroy();
end;

procedure TclTcpServer.DoDestroy;
begin
  FWorkerThreadPool.Free();
end;

procedure TclTcpServer.DoAcceptConnection(AConnection: TclCommandConnection);
begin
  if Assigned(OnAcceptConnection) then
  begin
    OnAcceptConnection(Self, AConnection);
  end;
end;

procedure TclTcpServer.DoCloseConnection(AConnection: TclCommandConnection);
begin
  if Assigned(OnCloseConnection) then
  begin
    OnCloseConnection(Self, AConnection);
  end;
end;

procedure TclTcpServer.DoReadConnection(AConnection: TclCommandConnection; AData: TStream);
begin
end;

procedure TclTcpServer.DoServerError(E: Exception);
begin
  if Assigned(OnServerError) then
  begin
    OnServerError(Self, E);
  end;
end;

procedure TclTcpServer.DoStart;
begin
  if Assigned(OnStart) then
  begin
    OnStart(Self);
  end;
end;

procedure TclTcpServer.DoStop;
begin
  if Assigned(OnStop) then
  begin
    OnStop(Self);
  end;
end;

type
  TclTcpServerOperation = (soServerRead, soServerWrite);

  TclTcpServerWorkItem = class(TclWorkItem)
  private
    FServer: TclTcpServer;
    FConnection: TclCommandConnection;
    FOperation: TclTcpServerOperation;
    procedure DoRead;
    procedure DoWrite;
  protected
    procedure Execute; override;
  public
    constructor Create(AServer: TclTcpServer; AConnection: TclCommandConnection; AOperation: TclTcpServerOperation);
    destructor Destroy; override;
  end;

procedure TclTcpServer.DoWriteConnection(AConnection: TclCommandConnection);
begin
end;

function TclTcpServer.GetConnection(Index: Integer): TclCommandConnection;
begin
  Result := TclCommandConnection(FServerThread.FConnections[Index]);
end;

function TclTcpServer.GetConnectionCount: Integer;
begin
  Result := FServerThread.FConnections.Count;
end;

procedure TclTcpServer.CloseConnection(AConnection: TclCommandConnection);
begin
{$IFDEF LOGGER}try clPutLogMessage(Self, edEnter, 'CloseConnection');{$ENDIF}
  FServerThread.FConnections.Remove(AConnection);
  try
    AConnection.Close(False);
    DoCloseConnection(AConnection);
  finally
    AConnection._Release();
  end;
{$IFDEF LOGGER}clPutLogMessage(Self, edLeave, 'CloseConnection'); except on E: Exception do begin clPutLogMessage(Self, edLeave, 'CloseConnection', E); raise; end; end;{$ENDIF}
end;

procedure TclTcpServer.DoGetCertificate(var ACertificate: TclCertificate; var Handled: Boolean);
begin
  if Assigned(OnGetCertificate) then
  begin
    OnGetCertificate(Self, ACertificate, Handled);
  end;
end;

procedure TclTcpServer.GetCertificate(Sender: TObject;
  var ACertificate: TclCertificate; var Handled: Boolean);
begin
  DoGetCertificate(ACertificate, Handled);
end;

procedure TclTcpServer.StartTls(AConnection: TclCommandConnection);
begin
  AConnection.NetworkStream := TclTlsNetworkStream.Create();
  TclTlsNetworkStream(AConnection.NetworkStream).OnGetCertificate := GetCertificate;
  TclTlsNetworkStream(AConnection.NetworkStream).TLSFlags := TLSFlags;
  TclTlsNetworkStream(AConnection.NetworkStream).RequireClientCertificate := RequireClientCertificate;
  TclTlsNetworkStream(AConnection.NetworkStream).OnVerifyPeer := VerifyClient;
  AConnection.OpenSession();
end;

procedure TclTcpServer.SetUseTLS(const Value: TclServerTlsMode);
begin
  FUseTLS := Value;
end;

function TclTcpServer.CreateConnection: TclCommandConnection;
begin
  Result := nil;
  DoCreateConnection(Result);
  if (Result = nil) then
  begin
    Result := CreateDefaultConnection();
  end;
end;

procedure TclTcpServer.DoCreateConnection(var AConnection: TclCommandConnection);
begin
  if Assigned(OnCreateConnection) then
  begin
    OnCreateConnection(Self, AConnection);