sbhttpscli.pas

著名的SecureBlackBox控件完整源码

(******************************************************)
(*                                                    *)
(*            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 SBHttpsCli;

interface

uses
  Classes, SysUtils, HttpProt, IcsUrl, SBWSocket, SBClient, SBX509, SBConstants,
  SBUtils, SBCustomCertStorage, SBSSLCommon;

type
  TElHttpsCli = class(THttpCli)
  private
    function GetOnCertificateChoose: TSBChooseCertificateEvent;
    function GetOnCertificateNeeded: TSBCertificateNeededEvent;
    function GetOnCertificateValidate: TSBCertificateValidateEvent;
    function GetVersions: TSBVersions;
    procedure SetOnCertificateChoose(Value: TSBChooseCertificateEvent);
    procedure SetOnCertificateNeeded(Value: TSBCertificateNeededEvent);
    procedure SetOnCertificateValidate(Value: TSBCertificateValidateEvent);
    procedure SetVersions(const Value: TSBVersions);
    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
    function GetSSLEnabled: Boolean;
    procedure SetSSLEnabled(Value: Boolean);
    function GetCipherSuite: TSBCipherSuite;
    function GetOnSSLEstablished: TSBSSLEstablishedEvent;
    procedure SetOnSSLEstablished(Value: TSBSSLEstablishedEvent);
    procedure SocketDNSLookupDone(Sender: TObject; ErrCode: Word); override;
    procedure DoRequestAsync(Rq : THttpRequest); override;
    function GetCompressionAlgorithm: TSBSSLCompressionAlgorithm;
    function GetCompressionAlgorithms(Index: TSBSSLCompressionAlgorithm): boolean;
    function GetOnCiphersNegotiated: TNotifyEvent;
    function GetOnError: TSBErrorEvent;
    procedure SetCompressionAlgorithms(Index: TSBSSLCompressionAlgorithm; Value:
        boolean);
    procedure SetOnCiphersNegotiated(Value: TNotifyEvent);
    procedure SetOnError(Value: TSBErrorEvent);
  public
    constructor Create(Aowner: TComponent); 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;
  published
    property Versions: TSBVersions read GetVersions write SetVersions;
    property CertStorage : TElCustomCertStorage
      read GetCertStorage write SetCertStorage;
    property OnCertificateChoose: TSBChooseCertificateEvent
      read GetOnCertificateChoose write SetOnCertificateChoose;
    property OnCertificateNeeded: TSBCertificateNeededEvent
      read GetOnCertificateNeeded write SetOnCertificateNeeded;
    property OnCertificateValidate: TSBCertificateValidateEvent
      read GetOnCertificateValidate write SetOnCertificateValidate;
    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 GetOnSSLEstablished
        write SetOnSSLEstablished;
  end;

procedure Register;

implementation

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

function TElHttpsCli.ClientGetCipherSuite(Index: TSBCipherSuite): Boolean;
begin
  Result := TElSecureWSocket(FCtrlSocket).CipherSuites[Index];
end;

procedure TElHttpsCli.ClientSetCipherSuite(Index: TSBCipherSuite;
  const Value: Boolean);
begin
  TElSecureWSocket(FCtrlSocket).CipherSuites[Index] := Value;
end;

constructor TElHttpsCli.Create(Aowner: TComponent);
begin
  inherited;
  FCtrlSocket.Free;
  FCtrlSocket := TElSecureWSocket.Create(Self);
  FCtrlSocket.OnSessionClosed := SocketSessionClosed;
  FCtrlSocket.OnDataAvailable := SocketDataAvailable;
  FCtrlSocket.OnSessionConnected := SocketSessionConnected;
  FCtrlSocket.OnDataSent := SocketDataSent;
  FCtrlSocket.OnDnsLookupDone := SocketDNSLookupDone;
  FCtrlSocket.OnSocksError := DoSocksError;
  FCtrlSocket.OnSocksConnected := DoSocksConnected;
  FCtrlSocket.OnError := SocketErrorTransfer;
end;

function TElHttpsCli.GetClientVersion: TSBVersion;
begin
  Result := TElSecureWSocket(FCtrlSocket).CurrentVersion;
end;

function TElHttpsCli.GetOnCertificateChoose: TSBChooseCertificateEvent;
begin
  Result := TElSecureWSocket(FCtrlSocket).OnCertificateChoose;
end;

function TElHttpsCli.GetOnCertificateNeeded: TSBCertificateNeededEvent;
begin
  Result := TElSecureWSocket(FCtrlSocket).OnCertificateNeeded;
end;

function TElHttpsCli.GetOnCertificateValidate: TSBCertificateValidateEvent;
begin
  Result := TElSecureWSocket(FCtrlSocket).OnCertificateValidate;
end;

function TElHttpsCli.GetVersions: TSBVersions;
begin
  Result := TElSecureWSocket(FCtrlSocket).Versions;
end;

procedure TElHttpsCli.SetOnCertificateChoose(Value: TSBChooseCertificateEvent);
begin
  TElSecureWSocket(FCtrlSocket).OnCertificateChoose := Value;
end;

procedure TElHttpsCli.SetOnCertificateNeeded(Value: TSBCertificateNeededEvent);
begin
  TElSecureWSocket(FCtrlSocket).OnCertificateNeeded := Value;
end;

procedure TElHttpsCli.SetOnCertificateValidate(Value: TSBCertificateValidateEvent);
begin
  TElSecureWSocket(FCtrlSocket).OnCertificateValidate := Value;
end;

procedure TElHttpsCli.SetVersions(const Value: TSBVersions);
begin
  TElSecureWSocket(FCtrlSocket).Versions := Value;
end;

function TElHttpsCli.GetCertStorage : TElCustomCertStorage;
begin
  Result := TElSecureWSocket(FCtrlSocket).CertStorage;
end;

procedure TElHttpsCli.SetCertStorage(Value : TElCustomCertStorage);
begin
  TElSecureWSocket(FCtrlSocket).CertStorage := Value;
end;

procedure TElHttpsCli.InternalValidate(var Validity : TSBCertificateValidity;
  var Reason : TSBCertificateValidityReason);
begin
  TElSecureWSocket(FCtrlSocket).InternalValidate(Validity, Reason);
end;

function TElHttpsCli.GetSSLEnabled: Boolean;
begin
  Result := TElSecureWSocket(FCtrlSocket).SSLEnabled;
end;

procedure TElHttpsCli.SetSSLEnabled(Value: Boolean);
begin
  TElSecureWSocket(FCtrlSocket).SSLEnabled := Value;
end;

function TElHttpsCli.GetCipherSuite: TSBCipherSuite;
begin
  Result := TElSecureWSocket(FCtrlSocket).CipherSuite;
end;

function TElHttpsCli.GetOnCertificateNeededEx: TSBCertificateNeededExEvent;
begin
  Result := TElSecureWSocket(FCtrlSocket).OnCertificateNeededEx;
end;

function TElHttpsCli.GetOnSSLEstablished: TSBSSLEstablishedEvent;
begin
  Result := TElSecureWSocket(FCtrlSocket).OnSSLEstablished;
end;

procedure TElHttpsCli.SetOnCertificateNeededEx(Value:
    TSBCertificateNeededExEvent);
begin
  TElSecureWSocket(FCtrlSocket).OnCertificateNeededEx := Value;
end;

procedure TElHttpsCli.SetOnSSLEstablished(Value: TSBSSLEstablishedEvent);
begin
  TElSecureWSocket(FCtrlSocket).OnSSLEstablished := Value;
end;

{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TElHttpsCli.SocketDNSLookupDone(Sender: TObject; ErrCode: Word);
var FSaveProto : string;
begin
  // here we are fooling ICS which attempts to block external SSL implementations
  FSaveProto := FProtocol;
  if SSLEnabled and
    ((lowercase(FProtocol) = 'https') or (lowercase(FProtocol) = '')) then
    FProtocol := 'http';
  inherited;
  FProtocol := FSaveProto;
end;

procedure TElHttpsCli.DoRequestAsync(Rq: THttpRequest);
var
    Proto, User, Pass, Host, Port, Path: String;
begin
  if SSLEnabled then
  begin
    ParseURL(FURL, Proto, User, Pass, Host, Port, Path);
    Proto := 'https'; 
    if Port = '' then
      Port := '443';
    FURL := Proto + '://';
    if (User <> '') or (Pass <> '') then
    begin
      FURL := FURL + User + ':' + Pass + '@';
    end;
    FURL := FURL + Host + ':' + Port + Path;
  end;
  inherited;
end;

function TElHttpsCli.GetCompressionAlgorithm: TSBSSLCompressionAlgorithm;
begin
  Result := TElSecureWSocket(FCtrlSocket).CompressionAlgorithm;
end;

function TElHttpsCli.GetCompressionAlgorithms(Index:
    TSBSSLCompressionAlgorithm): boolean;
begin
  Result := TElSecureWSocket(FCtrlSocket).CompressionAlgorithms[Index];
end;

function TElHttpsCli.GetOnCiphersNegotiated: TNotifyEvent;
begin
  Result := TElSecureWSocket(FCtrlSocket).OnCiphersNegotiated;
end;

function TElHttpsCli.GetOnError: TSBErrorEvent;
begin
  Result := TElSecureWSocket(FCtrlSocket).OnSSLError;
end;

procedure TElHttpsCli.RenegotiateCiphers;
begin
  TElSecureWSocket(FCtrlSocket).RenegotiateCiphers;
end;

procedure TElHttpsCli.SetOnCiphersNegotiated(Value: TNotifyEvent);
begin
  TElSecureWSocket(FCtrlSocket).OnCiphersNegotiated := Value;
end;

procedure TElHttpsCli.SetOnError(Value: TSBErrorEvent);
begin
  TElSecureWSocket(FCtrlSocket).OnSSLError := Value;
end;

procedure TElHttpsCli.SetCompressionAlgorithms(Index:
    TSBSSLCompressionAlgorithm; Value: boolean);
begin
  TElSecureWSocket(FCtrlSocket).CompressionAlgorithms[Index] := Value;
end;

end.