mainform.pas

著名的SecureBlackBox控件完整源码

unit MainForm;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ComCtrls, StdCtrls, SBServer, ScktComp, SBConstants, WinSock, SelectCertForm,
  SBUtils, SBX509, SBCustomCertStorage;

type
  TfrmMain = class(TForm)
    GroupBox1: TGroupBox;
    Edit1: TEdit;
    btnListen: TButton;
    Memo1: TMemo;
    StatusBar1: TStatusBar;
    Edit2: TEdit;
    btnSend: TButton;
    ServerSocket: TServerSocket;
    ElSecureServer: TElSecureServer;
    btnClose: TButton;
    GroupBox2: TGroupBox;
    cbUseClientAuthentication: TCheckBox;
    btnSelectCert: TButton;
    procedure ElSecureServerReceive(Sender: TObject; Buffer: Pointer;
      MaxSize: Integer; out Written: Integer);
    procedure ElSecureServerSend(Sender: TObject; Buffer: Pointer;
      Size: Integer);
    procedure ElSecureServerOpenConnection(Sender: TObject);
    procedure ElSecureServerCloseConnection(Sender: TObject;
      CloseDescription: Integer);
    procedure ElSecureServerData(Sender: TObject; Buffer: Pointer;
      Size: Integer);
    procedure ServerSocketAccept(Sender: TObject;
      Socket: TCustomWinSocket);
    procedure ServerSocketClientRead(Sender: TObject;
      Socket: TCustomWinSocket);
    procedure btnListenClick(Sender: TObject);
    procedure btnSendClick(Sender: TObject);
    procedure btnCloseClick(Sender: TObject);
    procedure ServerSocketClientDisconnect(Sender: TObject;
      Socket: TCustomWinSocket);
    procedure ServerSocketClientWrite(Sender: TObject;
      Socket: TCustomWinSocket);
    procedure btnSelectCertClick(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure cbUseClientAuthenticationClick(Sender: TObject);
    procedure ElSecureServerCertificateValidate(Sender: TObject;
      X509Certificate: TElX509Certificate; var Validate: Boolean);
  private
    FMemoryCertStorage: TElMemoryCertStorage;
  protected
    DataBuffer : array of byte;
    ClientSocket : TCustomWinSocket;
    procedure AttemptSocketWrite;
  public
    { Public declarations }
  end;

var
  frmMain: TfrmMain;

implementation

{$R *.DFM}

// this event handler is called by ElSecureServer when it needs some data
// to be read from socket
// Written parameter should be set according to number of bytes really read
procedure TfrmMain.ElSecureServerReceive(Sender: TObject; Buffer: Pointer;
  MaxSize: Integer; out Written: Integer);
begin
  Written := ClientSocket.ReceiveBuf(Buffer^, MaxSize);
  // on error ReceiveBuf returns negative value (-1), so explicitly setting
  // Written parameter to 0.
  if Written < 0 then
    Written := 0;
end;

// this event handler is called by ElSecureServer when it needs some data
// to be written to socket
procedure TfrmMain.ElSecureServerSend(Sender: TObject; Buffer: Pointer;
  Size: Integer);
var Pos : integer;
begin
  // caching output data in the internal buffer
  Pos := Length(DataBuffer);
  SetLength(DataBuffer, Pos + Size);
  Move(PChar(Buffer)^, DataBuffer[Pos], Size);
  // trying to send it to peer
  AttemptSocketWrite;
end;

// this event handler is called by ElSecureServer when SSL connection is opened.
// After this step, the data may be sent to peer using SendData/SendText methods.
procedure TfrmMain.ElSecureServerOpenConnection(Sender: TObject);
begin
  StatusBar1.Panels[0].Text := 'Client accepted';
  Memo1.Lines.Text := Memo1.Lines.Text + 'Client accepted. SSL version is';
  if ElSecureServer.CurrentVersion = sbSSL2 then
    Memo1.Lines.Text := Memo1.Lines.Text + ' SSL2'
  else if ElSecureServer.CurrentVersion = sbSSL3 then
    Memo1.Lines.Text := Memo1.Lines.Text + ' SSL3'
  else if ElSecureServer.CurrentVersion = sbTLS1 then
    Memo1.Lines.Text := Memo1.Lines.Text + ' TLS1'
  else if ElSecureServer.CurrentVersion = sbTLS11 then
    Memo1.Lines.Text := Memo1.Lines.Text + ' TLS1.1';
  Memo1.Lines.Text := Memo1.Lines.Text + #13#10;
end;

// this event handler is called by ElSecureServer when SSL connection is gracefully
// closed. No data should be sent using SendData/SendText methods after
// this event is fired.
procedure TfrmMain.ElSecureServerCloseConnection(Sender: TObject;
  CloseDescription: Integer);
begin
  StatusBar1.Panels[0].Text := 'Connection closed';
end;

// this event handler is called by ElSecureServer when some amount of data is
// received from peer. Buffer parameter specifies the array of decrypted data.
procedure TfrmMain.ElSecureServerData(Sender: TObject; Buffer: Pointer;
  Size: Integer);
var
  S : string;
begin
  SetLength(S, Size);
  Move(Buffer^, S[1], Size);
  Memo1.Lines.Text := Memo1.Lines.Text + '[CLIENT] ' + S + #13#10;
end;

// this event handler is called by ServerSocket when new socket connection is
// accepted
procedure TfrmMain.ServerSocketAccept(Sender: TObject;
  Socket: TCustomWinSocket);
begin
  ClientSocket := Socket;
  // enabling anonymous cipher suite as our simple server does not have
  // a certificate.
  ElSecureServer.CipherSuites[SB_SUITE_DH_ANON_RC4_MD5] := true;
  ElSecureServer.Open;
end;

// this event handler is called by ServerSocket to notify that some
// data has arrived to Socket.
procedure TfrmMain.ServerSocketClientRead(Sender: TObject;
  Socket: TCustomWinSocket);
begin
  // Pushing ElSecureServer to read data from socket using OnReceive event.
  ElSecureServer.DataAvailable;
end;

procedure TfrmMain.btnListenClick(Sender: TObject);
begin
  ElSecureServer.CertStorage := FMemoryCertStorage;

  ServerSocket.Port := StrToInt(Edit1.Text);
  ServerSocket.Active := true;
  StatusBar1.Panels[0].Text := 'Started listening';
end;

procedure TfrmMain.btnSendClick(Sender: TObject);
begin
  ElSecureServer.SendText(Edit2.Text);
  Memo1.Lines.Text := Memo1.Lines.Text + '[SERVER] ' + Edit2.Text + #13#10;
end;

procedure TfrmMain.btnCloseClick(Sender: TObject);
begin
  if ElSecureServer.Active then
    ElSecureServer.Close(true);
  ServerSocket.Active := false;
  StatusBar1.Panels[0].Text := 'Stopped listening';  
end;

procedure TfrmMain.ServerSocketClientDisconnect(Sender: TObject;
  Socket: TCustomWinSocket);
begin
  StatusBar1.Panels[0].Text := 'Client disconnected';
end;

procedure TfrmMain.ServerSocketClientWrite(Sender: TObject;
  Socket: TCustomWinSocket);
begin
  AttemptSocketWrite;
end;

// This routine tries to send as much buffered data as possible to the socket
procedure TfrmMain.AttemptSocketWrite;
  var Sent : integer;
    err  : integer;
begin
  if Length(DataBuffer) > 0 then
  begin
    Sent := ClientSocket.SendBuf(DataBuffer[0], Length(DataBuffer));
    if Sent = -1 then
    begin
      err := WSAGetLastError;
      if err <> WSAEWOULDBLOCK then
      begin
        SetLength(DataBuffer, 0);
        ShowMessage(Format('Error %d while trying to send the data', [err]));
        exit;
      end;
    end;
    if Sent > 0 then
    begin
      if (Sent < Length(DataBuffer)) then
      begin
        Move(DataBuffer[Sent], DataBuffer[0], Length(DataBuffer) - Sent);
        SetLength(DataBuffer, Length(DataBuffer) - Sent);
      end
      else
        SetLength(DataBuffer, 0);
    end;
  end;
end;

procedure TfrmMain.FormCreate(Sender: TObject);
begin
  FMemoryCertStorage := TElMemoryCertStorage.Create(nil);

  // Load default certificate
  LoadStorage('CertStorageDef.ucs', FMemoryCertStorage);
end;

procedure TfrmMain.FormDestroy(Sender: TObject);
begin
  FreeAndNil(FMemoryCertStorage);
end;

procedure TfrmMain.btnSelectCertClick(Sender: TObject);
begin
  with TfrmSelectCert.Create(Self) do
    try
      Mode := smServerCert;
      SetStorage(FMemoryCertStorage);
      if ShowModal() = mrOK then
      begin
        GetStorage(FMemoryCertStorage);
      end;

    finally
      Free;
    end;
end;

procedure TfrmMain.cbUseClientAuthenticationClick(Sender: TObject);
begin
  ElSecureServer.ClientAuthentication := cbUseClientAuthentication.Checked;
end;

// this event handler is called by ElSecureServer when it receives a certificate
// from client. Depending on your tasks, you may use different approaches to
// validate this certificate. Here the certificate validation is skipped.
procedure TfrmMain.ElSecureServerCertificateValidate(Sender: TObject;
  X509Certificate: TElX509Certificate; var Validate: Boolean);
begin
  Validate := True;
  // NEVER do this in real life since this makes security void. 
  // Instead validate the certificate as described on http://www.eldos.com/sbb/articles/1966.php
end;

initialization
SetLicenseKey('ADDCD14AD06709806817E0B3D7BFD0A2222D536FE156466C5D5FE65DB5DEAE76' + 
  'FFDEBC07E915A5751C12C01C783958872A38E4A5EDA140E7247E0F2E56442A3C' + 
  'F3E9347AD8FDE52083A0DFC86BC00ECB0FD0CF1B51159A2BCB84F6EA6349EF47' + 
  '5C15A59AFCC55F7C3AAD26C279628B5D91B1DC94BD2385354A70CCA3B76101D9' + 
  'F41C84A639FC3CCE4BA8F0CC4A66DCD150114A3F58C1AD46B7B94643741BC20A' + 
  '8DCA83AB921480951B423CAA19EF1863A47CA2C3422E7E5634BED98939A5AE43' + 
  'DE1E4BAD79E66D8A5C973B3455656C8C9B6FF024FADD6CDA02D0F506D98493C8' + 
  'BD1ED7B237DB75FA31F2C82654490CDDDEE24E19939137B9E1DB05508733B22F');


end.