📄 sbicsserversocket.pas

📁 著名的SecureBlackBox控件完整源码
💻 PAS
📖 第 1 页 / 共 2 页
字号:
12 下一页

(******************************************************)
(*                                                    *)
(*            EldoS SecureBlackbox Library            *)
(*                                                    *)
(*      Copyright (c) 2002-2007 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 SBICSServerSocket;

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,
  Windows,
  WSocket,
  WSocketS,
  SBServer,
  SBCustomCertStorage,
  SBSessionPool,
  SBX509,
  SBUtils,
  SBConstants,
  SBSSLConstants,
  SBSSLCommon;

type
  TElSecureWSocketClient = class;

  TSBICSCertificateValidateEvent = procedure(Sender: TObject; X509Certificate:
    TElX509Certificate;
    Socket: TElSecureWSocketClient; var Validate: boolean) of object;
  TSBSSLEstablishedEvent = procedure(Sender: TObject; Version: TSBVersion;
    CipherSuite: TSBCipherSuite) of object;

  TElSecureWSocketServer = class(TWSocketServer)
  private
    FOldClientConnectHandler: TWSocketClientConnectEvent;
    FOldClientCreateHandler: TWSocketClientCreateEvent;
    FOnCertificateValidate: TSBICSCertificateValidateEvent;
    FVersions: TSBVersions;
    FCipherSuites: array[SB_SUITE_FIRST..SB_SUITE_LAST] of boolean;
    FCertStorage: TElMemoryCertStorage;
    FClientCertStorage: TElCustomCertStorage;
    FSessionPool: TElSessionPool;
    FClientAuthentication: boolean;
    FForceCompression: boolean;
    FHandshakeTimeout : integer;
    procedure HandleCiphersNegotiated(Sender : TObject);
    procedure HandleError(Sender : TObject; ErrorCode: integer; Fatal: boolean;
        Remote : boolean);
  protected
    FOnCiphersNegotiated: TNotifyEvent;
    FOnError: TSBErrorEvent;
    FOnSSLEstablished: TSBSSLEstablishedEvent;
    FSSLEnabled: Boolean;
    procedure ClientConnectHandler(Sender: TObject; Client: TWSocketClient;
      Error: Word);
    procedure ClientCreateHandler(Sender: TObject; Client: TWSocketClient);
    function GetCipherSuites(Index: TSBCipherSuite): boolean;
    function GetVersions: TSBVersions;
    function GetCertStorage: TElMemoryCertStorage;
    function GetClientCertStorage: TElCustomCertStorage;
    function GetSessionPool: TElSessionPool;
    procedure SetCipherSuites(Index: TSBCipherSuite; Value: boolean);
    procedure SetVersions(Value: TSBVersions);
    procedure HandleCertificateValidate(Sender: TObject; X509Certificate:
      TElX509Certificate;
      Socket: TElSecureWSocketClient; var Validate: boolean);
    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;
    procedure Listen; override;
    property CipherSuites[Index: TSBCipherSuite]: boolean
    read GetCipherSuites write SetCipherSuites;
    property Versions: TSBVersions read FVersions write FVersions;
    property OnCertificateValidate: TSBICSCertificateValidateEvent
    read FOnCertificateValidate write FOnCertificateValidate;
    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 FClientAuthentication write
      FClientAuthentication;
  published
    property ForceCompression : boolean read FForceCompression write FForceCompression;
    property OnCiphersNegotiated: TNotifyEvent read FOnCiphersNegotiated write
        FOnCiphersNegotiated;
    property OnError: TSBErrorEvent read FOnError write FOnError;
    property OnSSLEstablished: TSBSSLEstablishedEvent read FOnSSLEstablished
      write FOnSSLEstablished;
    property SSLEnabled: Boolean read FSSLEnabled write FSSLEnabled default
      true;
    property HandshakeTimeout : integer read FHandshakeTimeout write FHandshakeTimeout default 0;
  end;

  TElSecureWSocketClient = class(TWSocketClient)
  private
    FSecureServer: TElSecureServer;
    FConnected: boolean;
    FErrorOccured: boolean;
    FBuffer: string;
    FDataReceived: Boolean;
    FRecvBuffer: Pointer;
    FRecvMaxSize: Integer;
    FRecvWritten: Integer;
    FOldOnDataAvailable: TDataAvailable;
    FOnCertificateValidate: TSBICSCertificateValidateEvent;
    FAlreadyClosing: boolean;
    FOnSSLEstablished: TSBSSLEstablishedEvent;
    procedure HandleReceive(Sender: TObject; Buffer: pointer; MaxSize: longint;
      out Written: longint);
    procedure HandleSend(Sender: TObject; Buffer: pointer; Size: 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);
    procedure DataAvailableForServer(Sender: TObject; Error: Word);
    procedure HandleCiphersNegotiated(Sender : TObject);
    procedure HandleError(Sender : TObject; ErrorCode: integer; Fatal: boolean;
        Remote : boolean);
  protected
    FOnCiphersNegotiated: TNotifyEvent;
    FOnError: TSBErrorEvent;
    procedure DoSSLEstablished;
    function GetCipherSuites(Index: TSBCipherSuite): boolean;
    function GetVersions: TSBVersions;
    function GetCipherSuite: TSBCipherSuite;
    function GetVersion: TSBVersion;
    function GetCertStorage: TElMemoryCertStorage;
    function GetClientCertStorage: TElCustomCertStorage;
    function GetSessionPool: TElSessionPool;
    function GetClientAuthentication: boolean;
    function GetCompressionAlgorithm: TSBSSLCompressionAlgorithm;
    function GetCompressionAlgorithms(Index: TSBSSLCompressionAlgorithm): boolean;
    function GetRcvdCount: LongInt; override;
    function GetSSLEnabled: Boolean;
    procedure SetCipherSuites(Index: TSBCipherSuite; Value: boolean);
    procedure SetVersions(Value: TSBVersions);
    procedure SetCertStorage(Value: TElMemoryCertStorage);
    procedure SetClientCertStorage(Value: TElCustomCertStorage);
    procedure SetSessionPool(Value: TElSessionPool);
    procedure SetClientAuthentication(Value: boolean);
    procedure SetSSLEnabled(Value: Boolean);

    {$ifdef ICS_V515_OR_ABOVE}
    function RealSend(Data : Pointer; Len : Integer) : Integer; override;
    procedure SetCompressionAlgorithms(Index: TSBSSLCompressionAlgorithm; Value:
        boolean);
    {$endif}
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Close; override;
    procedure StartConnection; override;
    function Send(Data: Pointer; Len: Integer): Integer; override;
    function SendStr({$IFDEF ICS_V508_OR_ABOVE}const{$ENDIF}Str: string):
      Integer; override;
    function Receive(Buffer: Pointer; BufferSize: Integer): Integer; override;
    procedure InternalValidate(var Validity: TSBCertificateValidity;
      var Reason: TSBCertificateValidityReason);
    procedure RenegotiateCiphers;
    property CipherSuites[Index: TSBCipherSuite]: boolean read GetCipherSuites
    write SetCipherSuites;
    property Versions: TSBVersions read GetVersions write SetVersions;
    property CipherSuite: TSBCipherSuite read GetCipherSuite;
    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 CompressionAlgorithm: TSBSSLCompressionAlgorithm read
        GetCompressionAlgorithm;
    property CompressionAlgorithms[Index: TSBSSLCompressionAlgorithm]: boolean read
        GetCompressionAlgorithms write SetCompressionAlgorithms;
    property OnCertificateValidate: TSBICSCertificateValidateEvent
    read FOnCertificateValidate write FOnCertificateValidate;
    property OnSSLEstablished: TSBSSLEstablishedEvent read FOnSSLEstablished
      write
    FOnSSLEstablished;
    property OnCiphersNegotiated: TNotifyEvent read FOnCiphersNegotiated write
        FOnCiphersNegotiated;
    property OnError: TSBErrorEvent read FOnError write FOnError;
  published
    property SSLEnabled: Boolean read GetSSLEnabled write SetSSLEnabled default
    true;
  end;

procedure Register;

implementation

uses SysUtils;

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

////////////////////////////////////////////////////////////////////////////////
// TElSecureWSocketServer

constructor TElSecureWSocketServer.Create(AOwner: TComponent);
var
  I: integer;
begin
  inherited;
  FSSLEnabled := true;
  FForceCompression := false;
  FClientClass := TElSecureWSocketClient;
  FHandshakeTimeout := 0;
  for I := SB_SUITE_RSA_RC4_MD5 to SB_SUITE_LAST do
    FCipherSuites[I] := True;
end;

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

procedure TElSecureWSocketServer.ClientConnectHandler(Sender: TObject; Client:
  TWSocketClient;
  Error: Word);
begin
  // intentionally left blank cause OnConnect only happens when SSL is established
  //if Assigned(FOldClientConnectHandler) then
  //  FOldClientConnectHandler(Sender, Client, Error);
end;

procedure TElSecureWSocketServer.ClientCreateHandler(Sender: TObject; Client:
  TWSocketClient);
begin
  TElSecureWSocketClient(Client).OnCertificateValidate :=
    HandleCertificateValidate;
  TElSecureWSocketClient(Client).OnSSLEstablished := FOnSSLEstablished;
  TElSecureWSocketClient(Client).OnCiphersNegotiated := HandleCiphersNegotiated;
  TElSecureWSocketClient(Client).OnError := HandleError;
  if Assigned(FOldClientCreateHandler) then
    FOldClientCreateHandler(Sender, Client);
end;

procedure TElSecureWSocketServer.Listen;
begin
  FOldClientConnectHandler := OnClientConnect;
  OnClientConnect := ClientConnectHandler;
  FOldClientCreateHandler := OnClientCreate;
  OnClientCreate := ClientCreateHandler;
  inherited;
end;

procedure TElSecureWSocketServer.HandleCertificateValidate(Sender: TObject;
  X509Certificate: TElX509Certificate; Socket: TElSecureWSocketClient; var
    Validate: boolean);
begin
  if Assigned(FOnCertificateValidate) then
    FOnCertificateValidate(Self, X509Certificate, Socket, Validate);
end;

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

function TElSecureWSocketServer.GetVersions: TSBVersions;
begin
  Result := FVersions;
end;

function TElSecureWSocketServer.GetCertStorage: TElMemoryCertStorage;
begin
  Result := FCertStorage;
end;
12 下一页
💿 文件大小 11641 K
👤 上传用户 sinoarts
📂 所属分类 Delphi控件源码
🏷️ 相关标签

#SecureBlackBox #控件 #源码
⌨️ 快捷键说明

复制代码 Ctrl + C
搜索代码 Ctrl + F
全屏模式 F11
切换主题 Ctrl + Shift + D
显示快捷键 ?
增大字号 Ctrl + =
减小字号 Ctrl + -