sbwsocket.pas

著名的SecureBlackBox控件完整源码

(******************************************************)
(*                                                    *)
(*            EldoS SecureBlackbox Library            *)
(*                                                    *)
(*     Copyright (c) 2002-2004 EldoS Corporation      *)
(*           http://www.secureblackbox.com            *)
(*                                                    *)
(******************************************************)

{$define ICS_V518_OR_ABOVE}

{$IFDEF ICS_V518_OR_ABOVE}
{$define ICS_V515_OR_ABOVE}
{$ENDIF}

{$IFDEF ICS_V515_OR_ABOVE}
{$define ICS_V508_OR_ABOVE}
{$ENDIF}

{$ifdef ICS_V508_OR_ABOVE}
{$define ICS_V416_OR_ABOVE}
{$endif}

unit SBWSocket;

interface

{$ifdef CLR}
    {$DEFINE DELPHI_NET}
    {$DEFINE NET_registered}
{$endif}

{$ifndef CLR}
{$ifndef FPC}
{$define DELPHI_WIN}
{$endif}
{$endif}

{$IFDEF VER120}
  {$DEFINE D_3_UP}
  {$DEFINE D_4_UP}
  {$DEFINE VCL40}
{$ENDIF}

{$IFDEF VER125}
  {$DEFINE B_3_UP}
  {$DEFINE B_4_UP}
  {$DEFINE B_4}
  {$DEFINE VCL40}
  {$DEFINE BUILDER_USED}
{$ENDIF}

{$IFDEF VER130}
	{$IFDEF BCB}
		{$DEFINE B_3_UP}
		{$DEFINE B_4_UP}
		{$DEFINE B_5_UP}
		{$DEFINE B_5}
		{$DEFINE VCL40}
		{$DEFINE VCL50}
		{$DEFINE BUILDER_USED}
    {$ELSE}
		{$DEFINE D_3_UP}
		{$DEFINE D_4_UP}
		{$DEFINE D_5_UP}
		{$DEFINE VCL40}
		{$DEFINE VCL50}
    {$ENDIF}
{$ENDIF}

{$IFDEF VER140}
	{$IFDEF BCB}
		{$DEFINE B_3_UP}
		{$DEFINE B_4_UP}
		{$DEFINE B_5_UP}
		{$DEFINE B_6_UP}
		{$DEFINE B_6}
		{$DEFINE VCL40}
		{$DEFINE VCL50}
		{$DEFINE VCL60}
		{$DEFINE BUILDER_USED}
    {$ELSE}
		{$DEFINE D_3_UP}
		{$DEFINE D_4_UP}
		{$DEFINE D_5_UP}
		{$DEFINE D_6_UP}
		{$DEFINE D_6}
		{$DEFINE VCL40}
		{$DEFINE VCL50}
		{$DEFINE VCL60}
		{.DEFINE USEADO}
    {$ENDIF}
{$ENDIF}


{$IFDEF VER150}
	{$IFNDEF BCB}
		{$DEFINE D_3_UP}
		{$DEFINE D_4_UP}
		{$DEFINE D_5_UP}
		{$DEFINE D_6_UP}
		{$DEFINE D_7_UP}
		{$DEFINE D_7}
		{$DEFINE VCL40}
		{$DEFINE VCL50}
		{$DEFINE VCL60}
		{$DEFINE VCL70}
		{.DEFINE USEADO}
    {$ENDIF}
{$ENDIF}

{$IFDEF VER160}
    {$DEFINE D_3_UP}
    {$DEFINE D_4_UP}
    {$DEFINE D_5_UP}
    {$DEFINE D_6_UP}
    {$DEFINE D_7_UP}
    {$DEFINE D_8_UP}
    {$DEFINE D_8}
    {$DEFINE VCL40}
    {$DEFINE VCL50}
    {$DEFINE VCL60}
    {$DEFINE VCL70}
    {$DEFINE VCL80}
    {.$DEFINE USE_NAME_SPACE} // Optional !!!
{$ENDIF}

{$IFDEF VER170}
    {$DEFINE D_3_UP}
    {$DEFINE D_4_UP}
    {$DEFINE D_5_UP}
    {$DEFINE D_6_UP}
    {$DEFINE D_7_UP}
    {$DEFINE D_8_UP}
    {$DEFINE D_9_UP}
    {$DEFINE D_9}
    {$DEFINE VCL40}
    {$DEFINE VCL50}
    {$DEFINE VCL60}
    {$DEFINE VCL70}
    {$DEFINE VCL80}
    {$DEFINE VCL90}
    {.$DEFINE USE_NAME_SPACE} // Optional !!!
{$ENDIF}

{$IFDEF VER180}
    {$DEFINE D_3_UP}
    {$DEFINE D_4_UP}
    {$DEFINE D_5_UP}
    {$DEFINE D_6_UP}
    {$DEFINE D_7_UP}
    {$DEFINE D_8_UP}
    {$DEFINE D_9_UP}
    {$DEFINE D_X_UP}
    {$DEFINE D_X}
    {$DEFINE VCL40}
    {$DEFINE VCL50}
    {$DEFINE VCL60}
    {$DEFINE VCL70}
    {$DEFINE VCL80}
    {$DEFINE VCL90}
    {$DEFINE VCL100}

    {$DEFINE B_3_UP}
    {$DEFINE B_4_UP}
    {$DEFINE B_5_UP}
    {$DEFINE B_6_UP}
    {$DEFINE B_X_UP}
    {$DEFINE B_X}
    {$ifndef DELPHI_NET}	    
    {$DEFINE BUILDER_USED}
    {$endif}
{$ENDIF}
    
{$ifndef CHROME}
{$ifndef DELPHI_NET}
{$IFDEF D_7_UP}
{$WARN UNSAFE_CODE OFF}
{$WARN UNSAFE_TYPE OFF}
{$WARN UNSAFE_CAST OFF}
{$ENDIF}
{$ENDIF}
{$ENDIF}


uses
  Classes,
  SysUtils,
  Windows,
  WSocket,
  //SBDumper,
  SBUtils,
  SBClient,
  SBX509,
  SBConstants,
  SBCustomCertStorage,
  SBSSLCommon;

type

  TSBSSLEstablishedEvent = procedure(Sender : TObject; Version : TSBVersion; CipherSuite : TSBCipherSuite) of object;

  TElSecureWSocket = class(TWSocket)
  private
    FBuffer: string;
    FDataReceived: Boolean;
    FSecureClient: TElSecureClient;
    FOldOnSessionConnected: TSessionConnected;
    FOldOnDataAvailable: TDataAvailable;
    FSocksConnected: boolean;
    RecvByClient,
    RecvFromSocket : integer;
    FErrorOccured : boolean;
    FCallOnData : boolean;
    FDataLeft: Boolean;
    FOnSSLEstablished: TSBSSLEstablishedEvent;
    {$ifdef ICS_V416_OR_ABOVE}
    FReceivedOnLastCall : boolean;
    {$endif}
    procedure OnSecureClientData(Sender: TObject; Buffer: pointer; Size:
      longint);
    procedure OnSecureClientRecv(Sender: TObject; Buffer: pointer; MaxSize: longint;
        {$ifndef BUIlDER_USED}out{$else}var{$endif} Written: longint);
    procedure OnSecureClientSend(Sender: TObject; Buffer: pointer; Size:
      longint);
    procedure HandleSecureClientClose(Sender : TObject; CloseReason : TSBCloseReason);
    procedure ClientMustOpen(Sender: TObject; Error: Word);
    procedure DataAvailableForClient(Sender: TObject; Error: Word);
    procedure ClientConnected(Sender: TObject);
    function GetVersions: TSBVersions;
    procedure SetVersions(const Value: TSBVersions);
    function GetOnCertificateChoose: TSBChooseCertificateEvent;
    function GetOnCertificateNeeded: TSBCertificateNeededEvent;
    function GetOnCertificateValidate: TSBCertificateValidateEvent;
    procedure SetOnCertificateChoose(Value: TSBChooseCertificateEvent);
    procedure SetOnCertificateNeeded(Value: TSBCertificateNeededEvent);
    procedure SetOnCertificateValidate(Value: TSBCertificateValidateEvent);
    function ClientGetCipherSuite(Index: TSBCipherSuite): Boolean;
    procedure ClientSetCipherSuite(Index: TSBCipherSuite;
      const Value: Boolean);
    function GetClientVersion: TSBVersion;
    function GetCertStorage: TElCustomCertStorage;
    procedure SetCertStorage(Value: TElCustomCertStorage);
    function GetOnCertificateNeededEx: TSBCertificateNeededExEvent;
    procedure SetOnCertificateNeededEx(Value: TSBCertificateNeededExEvent);
  protected
    procedure DoSSLEstablished;
    function GetSSLEnabled: Boolean;
    procedure SetSSLEnabled(Value: Boolean);
    function GetCipherSuite : TSBCipherSuite;
    function GetCompressionAlgorithm: TSBSSLCompressionAlgorithm;
    function GetCompressionAlgorithms(Index: TSBSSLCompressionAlgorithm): boolean;
    function GetOnCiphersNegotiated: TNotifyEvent;
    function GetOnError: TSBErrorEvent;
    function GetSSLActive: Boolean;
    procedure SetCompressionAlgorithms(Index: TSBSSLCompressionAlgorithm; Value:
        boolean);
    procedure SetOnCiphersNegotiated(Value: TNotifyEvent);
    procedure SetOnError(Value: TSBErrorEvent);
    procedure TriggerSessionClosed(Error : Word); override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Connect; override;
    procedure Close; override;
    procedure CloseDelayed; override;
    procedure NegotiateSSL;

    {$ifdef ICS_V515_OR_ABOVE}
    function RealSend(Data : Pointer; Len : Integer) : Integer; override;
    {$endif}
    function Send(Data: Pointer; Len: Integer): Integer; override;

    // NOTE: if you are using WSocket version 5.08 or above, define ICS_V508_OR_ABOVE at the beginning of this file
    function SendStr({$ifdef ICS_V508_OR_ABOVE} const {$endif}Str : String) : Integer; override;
    function Receive(Buffer: Pointer; BufferSize: Integer): Integer; override;
    function ReceiveStr: string; override;
    procedure InternalValidate(var Validity: TSBCertificateValidity;
      var Reason: TSBCertificateValidityReason);
    procedure RenegotiateCiphers;
    property CipherSuites[Index: TSBCipherSuite]: Boolean
    read ClientGetCipherSuite write ClientSetCipherSuite;
    property CurrentVersion: TSBVersion read GetClientVersion;
    property CipherSuite : TSBCipherSuite read GetCipherSuite;
    property CompressionAlgorithm: TSBSSLCompressionAlgorithm read
        GetCompressionAlgorithm;
    property CompressionAlgorithms[Index: TSBSSLCompressionAlgorithm]: boolean read
        GetCompressionAlgorithms write SetCompressionAlgorithms;
    property SSLActive: Boolean read GetSSLActive;
  published
    property Versions: TSBVersions read GetVersions write SetVersions;
    property OnCertificateChoose: TSBChooseCertificateEvent
    read GetOnCertificateChoose write SetOnCertificateChoose;
    property OnCertificateNeeded: TSBCertificateNeededEvent
    read GetOnCertificateNeeded write SetOnCertificateNeeded;
    property OnCertificateValidate: TSBCertificateValidateEvent
    read GetOnCertificateValidate write SetOnCertificateValidate;
    property CertStorage: TElCustomCertStorage
    read GetCertStorage write SetCertStorage;
    property SSLEnabled: Boolean read GetSSLEnabled write SetSSLEnabled;
    property OnCertificateNeededEx: TSBCertificateNeededExEvent read
        GetOnCertificateNeededEx write SetOnCertificateNeededEx;
    property OnCiphersNegotiated: TNotifyEvent read GetOnCiphersNegotiated write
        SetOnCiphersNegotiated;
    property OnSSLError: TSBErrorEvent read GetOnError write SetOnError;
    property OnSSLEstablished: TSBSSLEstablishedEvent read FOnSSLEstablished write
        FOnSSLEstablished;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('SSLBlackbox', [TElSecureWSocket]);
end;

constructor TElSecureWSocket.Create(AOwner: TComponent);
begin
  inherited;
  FSecureClient := TElSecureClient.Create(nil);
  FSecureClient.OnReceive := OnSecureClientRecv;
  FSecureClient.OnSend := OnSecureClientSend;
  FSecureClient.OnData := OnSecureClientData;
  FSecureClient.OnOpenConnection := ClientConnected;
  FSecureClient.OnCloseConnection := HandleSecureClientClose;
end;

procedure TElSecureWSocket.Connect;
var Mtd : Pointer;
begin
  FSocksConnected := false;
  Mtd := @TElSecureWSocket.ClientMustOpen;
  if Mtd <> TMethod(FOnSessionConnected).Code then
  begin
    FOldOnSessionConnected := OnSessionConnected;
    FOnSessionConnected := ClientMustOpen;
  end;
  Mtd := @TElSecureWSocket.DataAvailableForClient;
  if Mtd <> TMethod(FOnDataAvailable).Code then
  begin
    FOldOnDataAvailable := OnDataAvailable;
    FOnDataAvailable := DataAvailableForClient;
  end;
  inherited;
end;

procedure TElSecureWSocket.Close;
begin
  if Assigned(FOldOnSessionConnected) then
    FOnSessionConnected := FOldOnSessionConnected;
  FOldOnSessionConnected := nil;
  if Assigned(FOldOnDataAvailable) then
    FOnDataAvailable := FOldOnDataAvailable;
  FOldOnDataAvailable := nil;
  if not FSecureClient.Active then
    FErrorOccured := true;
  inherited;
  if FSecureClient.Active then
    FSecureClient.Close(true);
  { 'true' was added by II on June 18, 2004 not to make ElSecureClient
    send close_notify packet to socket (which might be closed) }
end;

procedure TElSecureWSocket.TriggerSessionClosed(Error : Word);
var
  OldLen : integer;
begin
  FDataReceived := false;
  repeat
    FSecureClient.DataAvailable;
  until  FErrorOccured or (not FDataReceived);

  FErrorOccured := false;
  // II 210604. Flushing data left in FBuffer.
  OldLen := Length(FBuffer);
  while Length(FBuffer) > 0 do
  begin
    TriggerDataAvailable(0);
    if Length(FBuffer) = OldLen then
      Break;
  end;
  inherited TriggerSessionClosed(Error);
end;

procedure TElSecureWSocket.CloseDelayed;
begin
  inherited CloseDelayed;
end; 

procedure TElSecureWSocket.OnSecureClientData(Sender: TObject; Buffer: pointer;
  Size: longint);
var oldSize : integer;
    oldBufL : integer;
begin
  if Size > 0 then
  begin
    OldSize := Length(FBuffer);
    SetLength(FBuffer, OldSize + Size);
    Move(PChar(Buffer)^, FBuffer[OldSize + 1], Size);
    inc(RecvFromSocket, Size);
  end;
  FDataReceived := True;
  while (Length(FBuffer) > 0) and (FState <> wsClosed) do
  begin
    oldBufL := Length(FBuffer);
    if (Assigned(FOldOnDataAvailable)) and FCallOnData then
      FOldOnDataAvailable(Self, 0);
    if oldBufL = Length(FBuffer) then break;
  end;
end;

procedure TElSecureWSocket.OnSecureClientRecv(Sender: TObject; Buffer: pointer; 
    MaxSize: longint; {$ifndef BUIlDER_USED}out{$else}var{$endif} Written: longint);
const
  WSAEWOULDBLOCK = 10035;
begin
  Written := inherited Receive(Buffer, MaxSize);
  if (Written < 0) and (LastError <> WSAEWOULDBLOCK) then
    FErrorOccured := true;