nxtsssltransport.pas

著名的SecureBlackBox控件完整源码

unit nxtsSSLTransport;

interface

uses
  Classes,
  SysUtils,

  Windows,

  SBConstants,
  SBSSLCommon,
  SBSSLConstants,
  SBClient,
  SBServer,
  SBCustomCertStorage,

  nxllBde,
  nxllTypes,
  nxllStreams,
  nxllComponent,
  nxllTransport,
  nxtsBaseSecuredTransport;

const

  ERRCODE_SSL_INVALID_CIPHERSUITE = $1A0;
  ERRCODE_SSL_NOT_OPENED          = $1A1;
  ERRCODE_SSL_SERVER_CLOSED       = $1A2;
  ERRCODE_SSL_SERVERSIDE_CLOSE    = $1A3;
  ERRCODE_SSL_CONNECTION_ERROR    = $1A3;
  ERRCODE_SSL_NEGOTIATION_FAILED  = $1A4;


  DBIERR_NX_SSL_INVALID_CIPHERSUITE = ERRBASE_NEXUS + ERRCODE_SSL_INVALID_CIPHERSUITE;
  DBIERR_NX_SSL_NOT_OPENED          = ERRBASE_NEXUS + ERRCODE_SSL_NOT_OPENED;
  DBIERR_NX_SSL_SERVER_CLOSED       = ERRBASE_NEXUS + ERRCODE_SSL_SERVER_CLOSED;
  DBIERR_NX_SSL_CONNECTION_ERROR    = ERRBASE_NEXUS + ERRCODE_SSL_CONNECTION_ERROR;
  DBIERR_NX_SSL_NEGOTIATION_FAILED  = ERRBASE_NEXUS + ERRCODE_SSL_NEGOTIATION_FAILED;

type

 TElBaseSSLConnectionProxy = class;

  TSSLClientReplyInfo = record
    riConnection: TElBaseSSLConnectionProxy;
    riReplyCallback: TnxReplyCallback;
    riReplyCookie: Integer;
    riSessionID: TnxSessionID;
    riMsgID: TnxMsgID;
    riTimeout : integer;
    riIsPost  : boolean;
  end;
  PSSLClientReplyInfo = ^TSSLClientReplyInfo;

  TSSLRequestHeader = packed record
    MessageID  : TnxMsgID;
    TimeOut    : Integer;
  end;
  PSSLRequestHeader = ^TSSLRequestHeader;

  TSSLReplyHeader = packed record
    MessageID  : TnxMsgID;
    ErrorCode  : Integer;
  end;

  EnxSSLTransportException = class(EnxSecuredTransportException);

  TElBaseSSLTransport = class(TnxBaseSecuredTransport)
  private
    FCipherSuites: TBits;
    FVersions: TSBVersions;

    FOnCertificateValidate: TSBCertificateValidateEvent;

    function GetCipherSuite(Index: TSBCipherSuite): boolean;
    procedure SetCipherSuite(Index: TSBCipherSuite; const Value: boolean);
  protected
    procedure SetMode(Value: TnxTransportMode);
    function GetMode: TnxTransportMode;

    class function nxcExceptionClass: EnxComponentExceptionClass; override;
  public
    constructor Create(AOwner: TComponent); override;

    property CipherSuites[Index: TSBCipherSuite]: boolean read GetCipherSuite
    write
      SetCipherSuite;
  published
    property OnCertificateValidate: TSBCertificateValidateEvent read
      FOnCertificateValidate write FOnCertificateValidate;
    
    property Versions: TSBVersions read FVersions write FVersions;
    property Mode: TnxTransportMode read GetMode write SetMode;
  end;

  TElClientSSLTransport = class(TElBaseSSLTransport)
  private
    FOnCertificateChoose: TSBChooseCertificateEvent;
    FOnCertificateNeeded: TSBCertificateNeededEvent;
    FOnCertificateNeededEx: TSBCertificateNeededExEvent;
    FCertStorage: TElCustomCertStorage;
  protected
    procedure SetCertStorage(Storage: TElCustomCertStorage);
    function bstGetConnectionClass: TnxSecuredConnectionProxyClass; override;
  public
    constructor Create(AOwner: TComponent); override;
  published
    property OnCertificateChoose: TSBChooseCertificateEvent read
      FOnCertificateChoose write FOnCertificateChoose;
    property OnCertificateNeeded: TSBCertificateNeededEvent read
      FOnCertificateNeeded write FOnCertificateNeeded;
    property OnCertificateNeededEx: TSBCertificateNeededExEvent read
      FOnCertificateNeededEx write FOnCertificateNeededEx;

    property CertStorage: TElCustomCertStorage read FCertStorage write
    SetCertStorage;
  end;

  TElServerSSLTransport = class(TElBaseSSLTransport)
  private
    FCertStorage: TElMemoryCertStorage;
    FClientCertStorage: TElCustomCertStorage;
  protected
    procedure SetCertStorage(Storage: TElMemoryCertStorage);
    procedure SetClientCertStorage(Storage: TElCustomCertStorage);

    function bstGetConnectionClass: TnxSecuredConnectionProxyClass; override;
  public
    constructor Create(AOwner: TComponent); override;
  published
    property CertStorage: TElMemoryCertStorage read FCertStorage write
      SetCertStorage;
    property ClientCertStorage: TElCustomCertStorage read FClientCertStorage
    write
      SetClientCertStorage;
  end;

  TElBaseSSLConnectionProxy = class(TnxBaseSecuredConnectionProxy)
  private
    FInBuffer: array of byte;
    FOutBuffer: array of byte;
    FDataBuffer: array of byte;
    FBuffering: integer;
    procedure HandleRecv(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);
  protected
    FErrorCode : integer;
  public
  end;

  TElClientSSLConnectionProxy = class(TElBaseSSLConnectionProxy)
  private
    sscTimeout : integer;
    sscSessionID: integer;
    procedure HandleAbortConnection(Sender: TObject; CloseReason:
      TSBCloseReason);
  protected
    FClient: TElSecureClient;
    procedure bscpInitialize; override;
    procedure bscpInternalPost(
              aTransport: TnxBaseTransport;
              aSessionID : TnxSessionID;
              aThreadPriority : TnxThreadPriority;
              aMsgID: TnxMsgID;
              aRequestData: Pointer;
              aRequestDataLen: TnxWord32;
              aTimeOut: Integer); override;

    procedure bscpInternalRequest(aTransport: TnxBaseTransport; aSessionID:
      TnxSessionID; aThreadPriority : TnxThreadPriority; aMsgID: TnxMsgID; aTimeOut: Integer; aRequestData: Pointer;
      aRequestDataLen: TnxWord32; aReplyCallback: TnxReplyCallback;
        aReplyCookie: Integer); override;
    procedure SendRequestFromBuffer(aTransport : TnxBaseTransport; aReplyInfo:
        PSSLClientReplyInfo; Priority : TnxThreadPriority = 0);
    procedure sscCreateClient;
    procedure sscIncomingHandshakeReply; overload;
    procedure sscIncomingReply(aReplyInfo: Pointer; aMsgID: TnxMsgID; aErrorCode:
        TnxResult; aReplyData : Pointer; aReplyDataLen : Integer); overload;
    procedure sscIncomingSecureReply(aReplyInfo: Pointer; aMsgID: TnxMsgID;
        aErrorCode: TnxResult); overload;
  public
    constructor CreateSender(aTransport: TnxBaseSecuredTransport; const
      aUserName: string; const aPassword: string; aTimeOut:
      Integer; aClientVersion: Integer; out aServerVersion: Integer; out
      aSessionID: TnxSessionID); override;
    destructor Destroy; override;
  end;

  TElServerSSLConnectionProxy = class(TElBaseSSLConnectionProxy)
  private
    FConnected : boolean;
    FWrapMsgID : integer;
    procedure HandleCloseConnection(Sender: TObject; CloseDescription: integer);
    procedure HandleOpenConnection(Sender: TObject);
  protected
    FServer: TElSecureServer;
    procedure bscpInitialize; override;
    procedure bscpInternalReply(aTransport: TnxBaseTransport; aMsgID: TnxMsgID; 
        aErrorCode: TnxResult; aReplyData: Pointer; aReplyDataLen : TnxWord32); 
        override;
    procedure bscpProcess(aMsg: PnxDataMessage); override;
    procedure sscCreateServer;
  public
    destructor Destroy; override;
  end;

const

  sslFakeUserName = 'ssl_fake';
  sslFakePassword = 'ssl_fake';

procedure Register;

implementation

const
  nxnmSecuredHandshake = $FFFC;
  nxnmSecuredRequest = $FFFB;
  nxnmSecuredPost = $FFFA;

procedure DumpBuffer(FileName : string; Buffer : Pointer; BufferLen : Integer);
begin
  with TFileStream.create(FileName, fmCreate or fmShareDenyWrite) do
  begin
    WriteBuffer(PChar(Buffer)^, BufferLen);
    Free;
  end;
end;

procedure ClientEmptyCallback(aMsgID: TnxMsgID;
  aErrorCode: TnxResult;
  aReplyData: Pointer;
  aReplyDataLen: Integer;
  aReplyCookie: Integer);
begin
  // intentionally left blank
end;

procedure ClientCallback(aMsgID: TnxMsgID;
  aErrorCode: TnxResult;
  aReplyData: Pointer;
  aReplyDataLen: Integer;
  aReplyCookie: Integer);
var
  riConnection: TElClientSSLConnectionProxy;
begin
  // this must be our message
  with PSSLClientReplyInfo(aReplyCookie)^.riConnection do
  begin
    SetLength(FInBuffer, aReplyDataLen);
    Move(PChar(aReplyData)^, FInBuffer[0], aReplyDataLen);
  end;
  riConnection := TElClientSSLConnectionProxy(PSSLClientReplyInfo(aReplyCookie)^.riConnection);

  if (aMsgID = nxnmSecuredRequest) or
     (aMsgID = nxnmSecuredPost) then
  begin
    if Assigned(PSSLClientReplyInfo(aReplyCookie)^.riReplyCallback) then
      TElClientSSLConnectionProxy(PSSLClientReplyInfo(aReplyCookie)^.riConnection).sscIncomingSecureReply(PSSLClientReplyInfo(aReplyCookie),
        aMsgID, aErrorCode);
  end
  else
  begin
    riConnection.sscIncomingHandshakeReply;
  end;
end;

constructor TElBaseSSLTransport.Create(AOwner: TComponent);
var
  i: integer;
begin
  inherited;
  FCipherSuites := TBits.Create;
  FCipherSuites.Size := SB_SUITE_LAST + 1;

  for I := SB_SUITE_RSA_RC4_MD5 to SB_SUITE_LAST do
    FCipherSuites.Bits[I] := True;

end;

function TElBaseSSLTransport.GetCipherSuite(Index: TSBCipherSuite): boolean;
begin
  if (Index < SB_SUITE_FIRST) or (Index > SB_SUITE_LAST) then
    raise EnxSSLTransportException.nxcCreate(Self, DBIERR_NX_SSL_INVALID_CIPHERSUITE, SInvalidCipherSuiteIndex, [Index]);
  Result := FCipherSuites.Bits[Integer(Index)];
end;

procedure TElBaseSSLTransport.SetCipherSuite(Index: TSBCipherSuite; const Value:
  boolean);
begin
  if (Index < SB_SUITE_FIRST) or (Index > SB_SUITE_LAST) then
    raise EnxSSLTransportException.nxcCreate(Self, DBIERR_NX_SSL_INVALID_CIPHERSUITE, SInvalidCipherSuiteIndex, [Index]);
  FCipherSuites.Bits[Integer(Index)] := Value;
end;

procedure TElBaseSSLTransport.SetMode(Value: TnxTransportMode);
begin
  if Self is TElClientSSLTransport then
    inherited Mode := nxtmSend
  else
    inherited Mode := nxtmListen;
end;

function TElBaseSSLTransport.GetMode: TnxTransportMode;
begin
  Result := inherited Mode;
end;

class function TElBaseSSLTransport.nxcExceptionClass: EnxComponentExceptionClass;
begin
  Result := EnxSSLTransportException;
end;

procedure TElBaseSSLConnectionProxy.HandleRecv(Sender: TObject; Buffer: pointer;
  MaxSize: Integer; out Written: Integer);
begin
  if MaxSize > Length(FInBuffer) then
    Written := Length(FInBuffer)
  else
    Written := MaxSize;

  Move(FInBuffer[0], PChar(Buffer)^, Written);

  if Written < Length(FInBuffer) then
    Move(FInBuffer[Written], FInBuffer[0], Length(FInBuffer) - Written);

  SetLength(FInBuffer, Length(FInBuffer) - Written);
end;

procedure TElBaseSSLConnectionProxy.HandleSend(Sender: TObject; Buffer: pointer;
  Size: Integer);
var
  SPos: integer;
begin
  SPos := Length(FOutBuffer);
  SetLength(FOutBuffer, SPos + Size);
  Move(PChar(Buffer)^, FOutBuffer[SPos], Size);
end;

procedure TElBaseSSLConnectionProxy.HandleData(Sender: TObject; Buffer: pointer;
    Size: longint);
var
  SPos: integer;
begin
  SPos := Length(FDataBuffer);
  SetLength(FDataBuffer, SPos + Size);
  Move(PChar(Buffer)^, FDataBuffer[SPos], Size);
end;



{ TElClientSSLTransport }

function TElClientSSLTransport.bstGetConnectionClass:
TnxSecuredConnectionProxyClass;
begin
  result := TElClientSSLConnectionProxy;
end;

constructor TElClientSSLTransport.Create(AOwner: TComponent);
var
  i: integer;
begin
  inherited;
  for I := SB_SUITE_FIRST to SB_SUITE_LAST do
    FCipherSuites.Bits[I] := True;

  Versions := [sbSSL2, sbSSL3, sbTLS1];

  Mode := nxtmSend;
end;

procedure TElClientSSLTransport.SetCertStorage(Storage: TElCustomCertStorage);
begin
  FCertStorage := Storage;
  if FCertStorage <> nil then
    FCertStorage.FreeNotification(Self)
end;

{ TElServerSSLTransport }

function TElServerSSLTransport.bstGetConnectionClass:
TnxSecuredConnectionProxyClass;
begin
  result := TElServerSSLConnectionProxy;
end;

constructor TElServerSSLTransport.Create(AOwner: TComponent);
var
  i: integer;
begin
  inherited;
  for I := SB_SUITE_RSA_RC4_MD5 to SB_SUITE_LAST do
    FCipherSuites.Bits[I] := True;

  Versions := [sbSSL3, sbTLS1];

  Mode := nxtmListen;
end;

procedure TElServerSSLTransport.SetCertStorage(Storage: TElMemoryCertStorage);
begin
  FCertStorage := Storage;
  if FCertStorage <> nil then
    FCertStorage.FreeNotification(Self)
end;

procedure TElServerSSLTransport.SetClientCertStorage(Storage:
  TElCustomCertStorage);
begin
  FClientCertStorage := Storage;
  if FClientCertStorage <> nil then
    FClientCertStorage.FreeNotification(Self)
end;

destructor TElServerSSLConnectionProxy.Destroy;
begin
  FServer.Free;
  FServer := nil;
  inherited;
end;

procedure TElServerSSLConnectionProxy.bscpInitialize;
begin
  inherited;
  sscCreateServer;
  FServer.Open;
end;

procedure TElServerSSLConnectionProxy.bscpInternalReply(aTransport: 
    TnxBaseTransport; aMsgID: TnxMsgID; aErrorCode: TnxResult; aReplyData : 
    Pointer; aReplyDataLen: TnxWord32);