sbserverindyintercept.pas

著名的SecureBlackBox控件完整源码

unit SBServerIndyIntercept;

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,
  IdSSLIntercept,
  IdSocketHandle,
  IdIntercept,
  SBUtils,
  SBServer,
  SBCustomCertStorage,
  SBSessionPool,
  SBX509,
  SBConstants;

type
  TElIndyConnectionSSLServerIntercept = class;
  TSBIndyCertificateValidateEvent = procedure(Sender: TObject;
    X509Certificate: TElX509Certificate; Intercept:
      TElIndyConnectionSSLServerIntercept;

    var Validate: boolean) of object;

  TElIndyServerSSLIntercept = class(TIdSSLServerIntercept)
  private
    FEnabledCipherSuites: array[SB_SUITE_FIRST..SB_SUITE_LAST] of boolean;
    FEnabledVersions: TSBVersions;
    FOnCertificateValidate: TSBIndyCertificateValidateEvent;
    FClientAuthentication: boolean;
    FCertStorage: TElMemoryCertStorage;
    FClientCertStorage: TElCustomCertStorage;
    FSessionPool: TElSessionPool;
    procedure HandleCertificateValidate(Sender: TObject;
      X509Certificate: TElX509Certificate; Intercept:
        TElIndyConnectionSSLServerIntercept;
      var Validate: boolean);
  protected
    function GetCipherSuites(Index: TSBCipherSuite): boolean;
    function GetVersions: TSBVersions;
    procedure SetCipherSuites(Index: TSBCipherSuite; Value: boolean);
    procedure SetVersions(Value: TSBVersions);
    procedure DoCertificateValidate(X509Certificate: TElX509Certificate;
      Intercept: TElIndyConnectionSSLServerIntercept; var Validate: boolean);
    function GetCertStorage: TElMemoryCertStorage;
    function GetClientCertStorage: TElCustomCertStorage;
    function GetSessionPool: TElSessionPool;
    procedure SetCertStorage(Value: TElMemoryCertStorage);
    procedure SetClientCertStorage(Value: TElCustomCertStorage);
    procedure SetSessionPool(Value: TElSessionPool);
    procedure Notification(AComponent: TComponent; Operation: TOperation);
      override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function Accept(ABinding: TIdSocketHandle): TIdConnectionIntercept;
      override;
    property CipherSuites[Index: TSBCipherSuite]: boolean read GetCipherSuites
    write SetCipherSuites;
  published
    property Versions: TSBVersions read GetVersions write SetVersions;
    property ClientAuthentication: boolean read FClientAuthentication
    write FClientAuthentication;
    property CertStorage: TElMemoryCertStorage read GetCertStorage
    write SetCertStorage;
    property ClientCertStorage: TElCustomCertStorage read GetClientCertStorage
    write SetClientCertStorage;
    property SessionPool: TElSessionPool read GetSessionPool write
      SetSessionPool;
    property OnCertificateValidate: TSBIndyCertificateValidateEvent
    read FOnCertificateValidate write FOnCertificateValidate;
  end;

  TElIndyConnectionSSLServerIntercept = class(TIdSSLConnectionIntercept)
  private
    FSecureServer: TElSecureServer;
    FBuffer: string;
    FDataReceived: boolean;
    FRecvBuffer: pointer;
    FRecvMaxSize: integer;
    FRecvWritten: integer;
    FConnected: boolean;
    FErrorOccured: boolean;
    FOnCertificateValidate: TSBIndyCertificateValidateEvent;
    procedure HandleSend(Sender: TObject; Buffer: pointer; Size: longint);
    procedure HandleReceive(Sender: TObject; Buffer: pointer; MaxSize: longint;
      {$ifndef BUIlDER_USED}out{$else}var{$endif} Written: longint);
    procedure HandleData(Sender: TObject; Buffer: pointer; Size: longint);
    procedure HandleOpenConnection(Sender: TObject);
    procedure HandleCloseConnection(Sender: TObject; CloseDescription: integer);
    procedure HandleCertificateValidate(Sender: TObject; X509Certificate:
      TElX509Certificate;
      var Validate: boolean);
  protected
    procedure DoActualSend(Buffer: pointer; Size: integer);
    procedure StartServer;
    function GetCipherSuite(Index: TSBCipherSuite): boolean;
    function GetCurrentCipherSuite: TSBCipherSuite;
    function GetVersions: TSBVersions;
    function GetVersion: TSBVersion;
    procedure SetCipherSuite(Index: TSBCipherSuite; Value: boolean);
    procedure SetVersions(Value: TSBVersions);
    function GetCertStorage: TElMemoryCertStorage;
    function GetClientCertStorage: TElCustomCertStorage;
    function GetSessionPool: TElSessionPool;
    procedure SetCertStorage(Value: TElMemoryCertStorage);
    procedure SetClientCertStorage(Value: TElCustomCertStorage);
    procedure SetSessionPool(Value: TElSessionPool);
    function GetClientAuthentication: boolean;
    procedure SetClientAuthentication(Value: boolean);
    procedure DoCertificateValidate(X509Certificate: TElX509Certificate; var
      Validate: boolean);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Disconnect; override;
    function Recv(var ABuf; ALen: integer): integer; override;
    function Send(var ABuf; ALen: integer): integer; override;
    procedure InternalValidate(var Validity: TSBCertificateValidity;
      var Reason: TSBCertificateValidityReason);
    property CipherSuites[Index: TSBCipherSuite]: boolean read GetCipherSuite
    write SetCipherSuite;
    property CurrentCipherSuite: TSBCipherSuite read GetCurrentCipherSuite;
    property Versions: TSBVersions read GetVersions write SetVersions;
    property Version: TSBVersion read GetVersion;
    property CertStorage: TElMemoryCertStorage read GetCertStorage
    write SetCertStorage;
    property ClientCertStorage: TElCustomCertStorage read GetClientCertStorage
    write SetClientCertStorage;
    property SessionPool: TElSessionPool read GetSessionPool write
      SetSessionPool;
    property ClientAuthentication: boolean read GetClientAuthentication
    write SetClientAuthentication;
    property OnCertificateValidate: TSBIndyCertificateValidateEvent
    read FOnCertificateValidate write FOnCertificateValidate;
  end;

procedure Register;

implementation

uses Sysutils,
  IdAntiFreezeBase,
  IdException,
  IdResourceStrings,
  IdStack,
  IdStackConsts;

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

////////////////////////////////////////////////////////////////////////////////
// TElIndyServerSSLIntercept

constructor TElIndyServerSSLIntercept.Create(AOwner: TComponent);
var
  I: integer;
begin
  inherited;
  for I := SB_SUITE_RSA_RC4_MD5 to SB_SUITE_LAST do
    FEnabledCipherSuites[I] := True;
  FEnabledVersions := [sbSSL3, sbTLS1];
end;

destructor TElIndyServerSSLIntercept.Destroy;
begin
  inherited;
  CertStorage := nil;
  ClientCertStorage := nil;
  SessionPool := nil;
end;

function TElIndyServerSSLIntercept.Accept(ABinding: TIdSocketHandle):
  TIdConnectionIntercept;
var
  I: integer;
begin
  Result := TElIndyConnectionSSLServerIntercept.Create(nil);
  TElIndyConnectionSSLServerIntercept(Result).FBinding := ABinding;
  for I := SB_SUITE_FIRST to SB_SUITE_LAST do
    TElIndyConnectionSSLServerIntercept(Result).CipherSuites[I] :=
      FEnabledCipherSuites[I];
  TElIndyConnectionSSLServerIntercept(Result).Versions := FEnabledVersions;
  TElIndyConnectionSSLServerIntercept(Result).ClientAuthentication :=
    FClientAuthentication;
  TElIndyConnectionSSLServerIntercept(Result).CertStorage := FCertStorage;
  TElIndyConnectionSSLServerIntercept(Result).ClientCertStorage :=
    FClientCertStorage;
  TElIndyConnectionSSLServerIntercept(Result).SessionPool := FSessionPool;
  TElIndyConnectionSSLServerIntercept(Result).OnCertificateValidate :=
    HandleCertificateValidate;
  TElIndyConnectionSSLServerIntercept(Result).StartServer;
end;

function TElIndyServerSSLIntercept.GetCipherSuites(Index: TSBCipherSuite):
  boolean;
begin
  Result := FEnabledCipherSuites[Index];
end;

function TElIndyServerSSLIntercept.GetVersions: TSBVersions;
begin
  Result := FEnabledVersions;
end;

procedure TElIndyServerSSLIntercept.SetCipherSuites(Index: TSBCipherSuite;
  Value: boolean);