cltcpclient.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 clTcpClient;

interface

{$I clVer.inc}

uses
  Classes, clTlsSocket, clSocket, clCert, clSspi;

type
  TclTcpTextEvent = procedure(Sender: TObject; const AText: string) of object;
  TclTcpListEvent = procedure(Sender: TObject; AList: TStrings) of object;

  TclClientTlsMode = (ctNone, ctAutomatic, ctImplicit, ctExplicit);

  TclTcpClient = class(TComponent)
  private
    FConnection: TclTcpClientConnection;
    FServer: string;
    FPort: Integer;
    FUseTLS: TclClientTlsMode;
    FInProgress: Boolean;
    FOnChanged: TNotifyEvent;
    FOnClose: TNotifyEvent;
    FOnOpen: TNotifyEvent;
    FOnGetCertificate: TclOnGetCertificateEvent;
    FOnVerifyServer: TclOnVerifyPeerEvent;
    FCertificateFlags: TclCertificateFlags;
    FTLSFlags: TclTlsFlags;
    FIPResolver: TclHostIPResolver;
    procedure SetServer(const Value: string);
    procedure SetPort_(const Value: Integer);
    procedure SetBatchSize(const Value: Integer);
    procedure SetTimeOut(const Value: Integer);
    procedure SetBitsPerSec(const Value: Integer);
    procedure SetCertificateFlags(const Value: TclCertificateFlags);
    procedure SetTLSFlags(const Value: TclTlsFlags);
    function GetBatchSize: Integer;
    function GetBitsPerSec: Integer;
    function GetTimeOut: Integer;
    function GetActive: Boolean;
    function GetIsTls: Boolean;
  protected
    procedure GetCertificate(Sender: TObject; var ACertificate: TclCertificate; var Handled: Boolean);
    procedure VerifyServer(Sender: TObject; ACertificate: TclCertificate;
      const AStatusText: string; AStatusCode: Integer; var AVerified: Boolean);
    procedure CheckConnected;
    procedure ExplicitStartTls;
    procedure AssignTlsStream(AConnection: TclSyncConnection);
    function GetDefaultPort: Integer; virtual;
    procedure OpenConnection(const AServer: string; APort: Integer); virtual;
    procedure InternalOpen; virtual;
    procedure InternalClose; virtual;
    procedure SetUseTLS(const Value: TclClientTlsMode); virtual;
    procedure DoDestroy; virtual;
    procedure Changed; dynamic;
    procedure DoOpen; dynamic;
    procedure DoClose; dynamic;
    procedure DoGetCertificate(var ACertificate: TclCertificate; var Handled: Boolean); dynamic;
    procedure DoVerifyServer(ACertificate: TclCertificate;
      const AStatusText: string; AStatusCode: Integer; var AVerified: Boolean); dynamic;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Open;
    procedure Close;
    procedure StartTls; virtual;
    property IsTls: Boolean read GetIsTls;
    property Connection: TclTcpClientConnection read FConnection;
    property Active: Boolean read GetActive;
    property Server: string read FServer write SetServer;
    property Port: Integer read FPort write SetPort_;
    property BatchSize: Integer read GetBatchSize write SetBatchSize default 8192;
    property TimeOut: Integer read GetTimeOut write SetTimeOut default 60000;
    property UseTLS: TclClientTlsMode read FUseTLS write SetUseTLS default ctNone;
    property CertificateFlags: TclCertificateFlags read FCertificateFlags write SetCertificateFlags default [];
    property TLSFlags: TclTlsFlags read FTLSFlags write SetTLSFlags default [tfUseTLS];
    property BitsPerSec: Integer read GetBitsPerSec write SetBitsPerSec default 0;
    property OnChanged: TNotifyEvent read FOnChanged write FOnChanged;
    property OnOpen: TNotifyEvent read FOnOpen write FOnOpen;
    property OnClose: TNotifyEvent read FOnClose write FOnClose;
    property OnGetCertificate: TclOnGetCertificateEvent read FOnGetCertificate write FOnGetCertificate;
    property OnVerifyServer: TclOnVerifyPeerEvent read FOnVerifyServer write FOnVerifyServer;
  end;

  TclTcpCommandClient = class(TclTcpClient)
  private
    FUserName: string;
    FPassword: string;
    FResponse: TStrings;
    FLastResponseCode: Integer;
    FOnReceiveResponse: TclTcpListEvent;
    FOnSendCommand: TclTcpTextEvent;
    FOnProgress: TclSocketProgressEvent;
    FOnProgress64: TclSocketProgress64Event;
    procedure SetPassword(const Value: string);
    procedure SetUserName(const Value: string);
    function ReceiveResponse(AddToLastString: Boolean): Boolean;
    function IsOkResponse(AResponseCode: Integer; const AOkResponses: array of Integer): Boolean;
    procedure DoDataProgress(Sender: TObject; ABytesProceed, ATotalBytes: Int64);
  protected
    procedure InternalOpen; override;
    procedure InternalClose; override;
    procedure DoDestroy; override;
    procedure OpenSession; virtual; abstract;
    procedure CloseSession; virtual; abstract;
    function GetResponseCode(const AResponse: string): Integer; virtual;
    function ParseResponse(AStartFrom: Integer; const AOkResponses: array of Integer): Integer;
    function InternalWaitingResponse(AStartFrom: Integer;
      const AOkResponses: array of Integer): Integer;
    procedure WaitingResponse(const AOkResponses: array of Integer); virtual;
    procedure InternalSendCommandSync(const ACommand: string;
      const AOkResponses: array of Integer); virtual;
    procedure DoSendCommand(const AText: string); dynamic;
    procedure DoReceiveResponse(AList: TStrings); dynamic;
    procedure DoProgress(ABytesProceed, ATotalBytes: Int64); dynamic;
  public
    constructor Create(AOwner: TComponent); override;
    procedure SendCommand(const ACommand: string);
    procedure SendCommandSync(const ACommand: string;
      const AOkResponses: array of Integer); overload;
    procedure SendCommandSync(const ACommand: string;
      const AOkResponses: array of Integer; const Args: array of const); overload;
    procedure SendSilentCommand(const ACommand: string;
      const AOkResponses: array of Integer); overload;
    procedure SendSilentCommand(const ACommand: string;
      const AOkResponses: array of Integer; const Args: array of const); overload;
    procedure SendMultipleLines(ALines: TStrings);
    procedure WaitMultipleLines(ATotalBytes: Int64); virtual;
    property Response: TStrings read FResponse;
    property LastResponseCode: Integer read FLastResponseCode;
    property UserName: string read FUserName write SetUserName;
    property Password: string read FPassword write SetPassword;
    property OnSendCommand: TclTcpTextEvent read FOnSendCommand write FOnSendCommand;
    property OnReceiveResponse: TclTcpListEvent read FOnReceiveResponse write FOnReceiveResponse;
    property OnProgress: TclSocketProgressEvent read FOnProgress write FOnProgress;
    property OnProgress64: TclSocketProgress64Event read FOnProgress64 write FOnProgress64;
  end;

resourcestring
  cNotConnectedError = 'The connection is not active';
  cLineSizeInvalid = 'The data line length must be lower or equal to BatchSize';

const
  SOCKET_WAIT_RESPONSE = 0;
  SOCKET_DOT_RESPONSE = 1;

implementation

uses
  SysUtils, WinSock, clUtils{$IFDEF DEMO}, Forms, Windows{$ENDIF}{$IFDEF LOGGER}, clLogger{$ENDIF};

{ TclTcpClient }

procedure TclTcpClient.Changed;
begin
  if Assigned(FOnChanged) then
  begin
    FOnChanged(Self);
  end;
end;

procedure TclTcpClient.CheckConnected;
begin
  if not Active then
  begin
    RaiseSocketError(cNotConnectedError, -1);
  end;
  Assert(FConnection <> nil);
end;

procedure TclTcpClient.Close;
var
  b: Boolean;
begin
  FIPResolver.Abort();
  b := Active;
  InternalClose();
  if b then
  begin
    DoClose();
  end;
end;

constructor TclTcpClient.Create(AOwner: TComponent);
var
  wsaData: TWSAData;
  res: Integer;
begin
  inherited Create(AOwner);
  res := WSAStartup($202, wsaData);
  if (res <> 0) then
  begin
    RaiseSocketError(WSAGetLastError());
  end;
  FIPResolver := TclHostIPResolver.Create();
  FConnection := TclTcpClientConnection.Create();
  BatchSize := 8192;
  TimeOut := 60000;
  BitsPerSec := 0;
  FUseTLS := ctNone;
  FTLSFlags := [tfUseTLS];
end;

destructor TclTcpClient.Destroy;
begin
  Close();
  DoDestroy();
  FConnection.Free();
  FIPResolver.Free();
  WSACleanup();
  inherited Destroy();
end;

procedure TclTcpClient.DoClose;
begin
  if Assigned(OnClose) then
  begin
    OnClose(Self);
  end;
end;

procedure TclTcpClient.DoDestroy;
begin
end;

procedure TclTcpClient.DoOpen;
begin
  if Assigned(OnOpen) then
  begin
    OnOpen(Self);
  end;
end;

procedure TclTcpClient.InternalClose;
begin
  FConnection.Close(True);
end;

procedure TclTcpClient.InternalOpen;
begin
{$IFDEF DEMO}
{$IFNDEF STANDALONEDEMO}
  if FindWindow('TAppBuilder', nil) = 0 then
  begin
    MessageBox(0, 'This demo version can be run under Delphi/C++Builder IDE only. ' +
      'Please visit www.clevercomponents.com to purchase your ' +
      'copy of the library.', 'Information', MB_ICONEXCLAMATION  or MB_TASKMODAL or MB_TOPMOST);
    ExitProcess(1);
  end;
{$ENDIF}
{$ENDIF}

  if (BatchSize < 1) then
  begin
    RaiseSocketError(cBatchSizeInvalid, -1);
  end;
  OpenConnection(Server, Port);
end;

procedure TclTcpClient.Open;
begin
  if Active then Exit;
  try
    InternalOpen();
    DoOpen();
  except
    FInProgress := True;
    try
      Close();
    except
      on EclSocketError do ;
    end;
    FInProgress := False;

    raise;
  end;
end;

procedure TclTcpClient.SetBatchSize(const Value: Integer);
begin
  if (BatchSize <> Value) then
  begin
    Connection.BatchSize := Value;
    Changed();
  end;
end;

procedure TclTcpClient.SetPort_(const Value: Integer);
begin
  if (FPort <> Value) then
  begin
    FPort := Value;
    Changed();
  end;
end;

procedure TclTcpClient.SetServer(const Value: string);
begin
  if (FServer <> Value) then
  begin
    FServer := Value;
    Changed();
  end;
end;

procedure TclTcpClient.SetTimeOut(const Value: Integer);
begin
  if (TimeOut <> Value) then
  begin
    Connection.TimeOut := Value;
    Changed();
  end;
end;

procedure TclTcpClient.SetUseTLS(const Value: TclClientTlsMode);
begin
  if (FUseTLS <> Value) then
  begin
    FUseTLS := Value;
    Changed();
  end;
end;

procedure TclTcpClient.SetBitsPerSec(const Value: Integer);
begin
  if (BitsPerSec <> Value) then
  begin
    Connection.BitsPerSec := Value;
    Changed();
  end;
end;

function TclTcpClient.GetBatchSize: Integer;
begin
  Result := Connection.BatchSize;
end;

function TclTcpClient.GetBitsPerSec: Integer;
begin
  Result := Connection.BitsPerSec;
end;

function TclTcpClient.GetTimeOut: Integer;
begin
  Result := Connection.TimeOut;
end;

function TclTcpClient.GetActive: Boolean;
begin
  Result := Connection.Active;
end;

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

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

function TclTcpClient.GetDefaultPort: Integer;
begin
  Result := 0;
end;

procedure TclTcpClient.AssignTlsStream(AConnection: TclSyncConnection);
var
  tlsStream: TclTlsNetworkStream;
begin
  tlsStream := TclTlsNetworkStream.Create();
  AConnection.NetworkStream := tlsStream;
  tlsStream.CertificateFlags := CertificateFlags;
  tlsStream.TLSFlags := TLSFlags;
  tlsStream.TargetName := Server;
  tlsStream.OnGetCertificate := GetCertificate;
  tlsStream.OnVerifyPeer := VerifyServer;
end;

procedure TclTcpClient.OpenConnection(const AServer: string; APort: Integer);
var
  ip: string;
  addr: Integer;
begin
  ip := AServer;
  addr := inet_addr(PChar(ip));
  if (addr = Integer(INADDR_NONE)) then
  begin
    ip := FIPResolver.GetHostIP(ip, TimeOut);
  end;

  if ((UseTLS = ctAutomatic) and (Port <> GetDefaultPort()))
    or (UseTLS = ctImplicit) then
  begin
    AssignTlsStream(Connection);
  end else
  begin
    Connection.NetworkStream := TclNetworkStream.Create();
  end;

  Connection.Open(ip, APort);
end;

procedure TclTcpClient.ExplicitStartTls;
begin
  if ((UseTLS = ctAutomatic) and (Port = GetDefaultPort()))
    or (UseTLS = ctExplicit) then
  begin
    StartTls();
  end;
end;

procedure TclTcpClient.StartTls;
begin
  if (UseTLS = ctNone) then
  begin
    UseTLS := ctExplicit;
  end;
  try
    AssignTlsStream(Connection);
    Connection.OpenSession();
  except
    FInProgress := True;
    try
      Close();
    except
      on EclSocketError do ;
    end;
    FInProgress := False;

    raise;
  end;
end;