myssliohandler.pas

Crlab公司用来连接MySQL数据库的控件

unit MySSLIOHandler;

interface

uses
{$IFNDEF CLR}
  CLRClasses,
{$ENDIF}
  Classes, MySqlVio, MemUtils, ScSSLClient, ScBridge, ScCryptoAPIStorage;

type
  TMySSLIOHandler = class (TMyIOHandler)
  private
    FCipherSuites: TScSSLCipherSuites;
    FStorage: TScStorage;
    FCertName: string;
    FCACertName: string;
    FOnServerCertValidate: TScServerCertValidate;

    function CheckDefaultCipherSuites: boolean;
    procedure SetCipherSuites(Value: TScSSLCipherSuites);
    procedure SetStorage(Value: TScStorage);
    procedure DoServerCertValidate(Sender: TObject;
      ServerCertificate: TScCertificate; var Accept: boolean);

  protected
    procedure Notification(Component: TComponent; Operation: TOperation); override;
    {$IFNDEF CLR}class{$ENDIF} procedure SetIsSecure(Handle: TMyIOHandle; const Value: Boolean); override;
    {$IFNDEF CLR}class{$ENDIF} function GetIsSecure(Handle: TMyIOHandle): Boolean; override;

  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;

    function Connect(const Server: string; const Port: integer;
      const SSL_key, SSL_cert, SSL_ca: string): TMyIOHandle; override;
    {$IFNDEF CLR}class{$ENDIF} procedure Disconnect(Handle: TMyIOHandle); override;
    {$IFNDEF CLR}class{$ENDIF} function Read(Handle: TMyIOHandle; {$IFDEF CLR}var{performance opt}{$ENDIF} buffer: TValueArr; offset, count: integer): integer; override;
    {$IFNDEF CLR}class{$ENDIF} function Write(Handle: TMyIOHandle; const buffer: TValueArr; offset, count: integer): integer;  override;

    {$IFNDEF CLR}class{$ENDIF} function GetTimeout(Handle: TMyIOHandle): integer; override;
    {$IFNDEF CLR}class{$ENDIF} procedure SetTimeout(Handle: TMyIOHandle; Value: integer); override;

  published
    property CipherSuites: TScSSLCipherSuites read FCipherSuites write SetCipherSuites stored CheckDefaultCipherSuites;
    property Storage: TScStorage read FStorage write SetStorage;
    property CertName: string read FCertName write FCertName;
    property CACertName: string read FCACertName write FCACertName;

    property OnServerCertValidate: TScServerCertValidate read FOnServerCertValidate write FOnServerCertValidate;
  end;

implementation

uses
  ScConsts, ScSslTypes, MyAccess;

{ TMySSLIOHandler }

constructor TMySSLIOHandler.Create(AOwner: TComponent);
begin
  inherited;

  FCipherSuites := TScSSLCipherSuites.Create(Self, TScSSLCipherSuiteItem);
  (FCipherSuites.Add as TScSSLCipherSuiteItem).CipherAlgorithm := caRSA_AES_256_SHA;
  (FCipherSuites.Add as TScSSLCipherSuiteItem).CipherAlgorithm := caRSA_AES_128_SHA;
  (FCipherSuites.Add as TScSSLCipherSuiteItem).CipherAlgorithm := caRSA_RC4_128_SHA;
  (FCipherSuites.Add as TScSSLCipherSuiteItem).CipherAlgorithm := caRSA_RC4_128_MD5;
  (FCipherSuites.Add as TScSSLCipherSuiteItem).CipherAlgorithm := caRSA_3DES_168_SHA;
end;

destructor TMySSLIOHandler.Destroy;
begin
  FCipherSuites.Free;
  inherited;
end;

function TMySSLIOHandler.Connect(const Server: string; const Port: integer;
  const SSL_key, SSL_cert, SSL_ca: string): TMyIOHandle;
var
  SSLClient: TScSSLClient;
  St: TScCryptoAPIStorage;
  Cert: TScCertificate;
begin
  SSLClient := TScSSLClient.Create(Self);
  try
    SSLClient.HostName := Server;
    SSLClient.Port := Port;
    SSLClient.CipherSuites := CipherSuites;

    if Storage <> nil then begin
      SSLClient.Storage := Storage;
      SSLClient.CACertName := CACertName;
      SSLClient.CertName := CertName;
    end
    else begin
      St := TScCryptoAPIStorage.Create(SSLClient);
      St.CertProviderType := ptMemory;
      Cert := TScCertificate.Create(St.Certificates);
      Cert.CertName := 'cacert';
      Cert.ImportFrom(SSL_ca);
      SSLClient.CACertName := 'cacert';

      if SSL_cert <> '' then begin
        Cert := TScCertificate.Create(St.Certificates);
        Cert.CertName := 'cert';
        Cert.ImportFrom(SSL_cert);
        if SSL_key <> '' then
          Cert.Key.ImportFrom(SSL_key);

        SSLClient.CertName := 'cert';
      end;

      SSLClient.Storage := St;
    end;

    SSLClient.OnServerCertValidate := DoServerCertValidate;
    SSLClient.Connect;
  except
    SSLClient.Free;
    raise;
  end;

  Result := SSLClient;
end;

{$IFNDEF CLR}class{$ENDIF} procedure TMySSLIOHandler.Disconnect(Handle: TMyIOHandle);
var
  Client: TScSSLClient;
begin
  Client := Handle as TScSSLClient;
  Client.Connected := False;
  Client.Free;
end;

{$IFNDEF CLR}class{$ENDIF} function TMySSLIOHandler.Read(Handle: TMyIOHandle; {$IFDEF CLR}var{performance opt}{$ENDIF} buffer: TValueArr; offset, count: integer): integer;
var
  Client: TScSSLClient;
begin
  Client := Handle as TScSSLClient;
  Result := Client.ReadBuffer(buffer{$IFNDEF CLR}[offset]{$ELSE}, offset{$ENDIF}, count);
end;

{$IFNDEF CLR}class{$ENDIF} function TMySSLIOHandler.Write(Handle: TMyIOHandle;
  const buffer: TValueArr; offset, count: integer): integer;
var
  Client: TScSSLClient;
begin
  Client := Handle as TScSSLClient;
  Result := Client.WriteBuffer(buffer{$IFNDEF CLR}[offset]{$ELSE}, offset{$ENDIF}, count);
end;

{$IFNDEF CLR}class{$ENDIF} function TMySSLIOHandler.GetTimeout(Handle: TMyIOHandle): integer;
var
  Client: TScSSLClient;
begin
  Client := Handle as TScSSLClient;
  Result := Client.Timeout;
end;

{$IFNDEF CLR}class{$ENDIF} procedure TMySSLIOHandler.SetTimeout(Handle: TMyIOHandle; Value: integer);
var
  Client: TScSSLClient;
begin
  Client := Handle as TScSSLClient;
  Client.Timeout := Value;
end;

procedure TMySSLIOHandler.Notification(Component: TComponent; Operation: TOperation);
begin
  if (Component = FStorage) and (Operation = opRemove) then
    Storage := nil;

  inherited;
end;

{$IFNDEF CLR}class{$ENDIF} procedure TMySSLIOHandler.SetIsSecure(Handle: TMyIOHandle; const Value: Boolean);
var
  Client: TScSSLClient;
begin
  Client := Handle as TScSSLClient;
  Client.IsSecure := Value;
end;

{$IFNDEF CLR}class{$ENDIF} function TMySSLIOHandler.GetIsSecure(Handle: TMyIOHandle): Boolean;
var
  Client: TScSSLClient;
begin
  Client := Handle as TScSSLClient;
  Result := Client.IsSecure;
end;

function TMySSLIOHandler.CheckDefaultCipherSuites: boolean;
begin
  Result := not ((FCipherSuites.Count = 5) and
                 (((FCipherSuites.Items[0] as TScSSLCipherSuiteItem).CipherAlgorithm = caRSA_AES_256_SHA) and
                  ((FCipherSuites.Items[1] as TScSSLCipherSuiteItem).CipherAlgorithm = caRSA_AES_128_SHA) and
                  ((FCipherSuites.Items[2] as TScSSLCipherSuiteItem).CipherAlgorithm = caRSA_RC4_128_SHA) and
                  ((FCipherSuites.Items[3] as TScSSLCipherSuiteItem).CipherAlgorithm = caRSA_RC4_128_MD5) and
                  ((FCipherSuites.Items[4] as TScSSLCipherSuiteItem).CipherAlgorithm = caRSA_3DES_168_SHA)));
end;

procedure TMySSLIOHandler.SetCipherSuites(Value: TScSSLCipherSuites);
begin
  if Value <> FCipherSuites then begin
    FCipherSuites.Assign(Value);
  end;
end;

procedure TMySSLIOHandler.SetStorage(Value: TScStorage);
begin
  if FStorage <> Value then begin
    if FStorage <> nil then
      FStorage.RemoveFreeNotification(Self);

    FStorage := Value;

    if Value <> nil then
      Value.FreeNotification(Self);
  end;
end;

procedure TMySSLIOHandler.DoServerCertValidate(Sender: TObject;
  ServerCertificate: TScCertificate; var Accept: boolean);
begin
  if Assigned(FOnServerCertValidate) then
    FOnServerCertValidate(Self, ServerCertificate, Accept);
end;

end.