mainform.pas

著名的SecureBlackBox控件完整源码

unit MainForm;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  SBSessionPool, ScktComp, SBServerSockets, StdCtrls, SBX509, SBUtils,
  SBCustomCertStorage, ComCtrls, SBConstants, SBSSLConstants;

type
  TfrmMain = class(TForm)
    ServerSocket: TElSecureServerSocket;
    ElSessionPool: TElSessionPool;
    gbConnProps: TGroupBox;
    lPort: TLabel;
    editPort: TEdit;
    lCertificate: TLabel;
    editCert: TEdit;
    btnBrowse: TButton;
    lCertPass: TLabel;
    editCertPassword: TEdit;
    cbSSL2: TCheckBox;
    cbSSL3: TCheckBox;
    cbTLS1: TCheckBox;
    cbTLS11: TCheckBox;
    btnActivate: TButton;
    CertStorage: TElMemoryCertStorage;
    Cert: TElX509Certificate;
    gbLog: TGroupBox;
    gbConnections: TGroupBox;
    lvConnections: TListView;
    lvLog: TListView;
    btnTerminate: TButton;
    OpenDialog: TOpenDialog;
    cbCompression: TCheckBox;
    procedure btnActivateClick(Sender: TObject);
    procedure btnBrowseClick(Sender: TObject);
    procedure ServerSocketAccept(Sender: TObject;
      Socket: TCustomWinSocket);
    procedure ServerSocketCiphersNegotiated(Sender: TObject);
    procedure ServerSocketError(Sender: TObject; ErrorCode: Integer; Fatal,
      Remote: Boolean);
    procedure ServerSocketClientConnect(Sender: TObject;
      Socket: TCustomWinSocket);
    procedure ServerSocketClientDisconnect(Sender: TObject;
      Socket: TCustomWinSocket);
    procedure ServerSocketSecureClientConnect(Sender: TObject;
      Socket: TElSecureServerClientWinSocket);
    procedure btnTerminateClick(Sender: TObject);
    procedure ServerSocketClientRead(Sender: TObject;
      Socket: TElSecureServerClientWinSocket);
  private
    procedure Log(const S : string);
  public
    { Public declarations }
  end;

var
  frmMain: TfrmMain;

implementation

{$R *.DFM}

procedure TfrmMain.Log(const S : string);
var
  Item : TListItem;
begin
  Item := lvLog.Items.Add;
  Item.Caption := TimeToStr(Now);
  Item.SubItems.Add(S);
end;

procedure TfrmMain.btnActivateClick(Sender: TObject);
var
  F : TFileStream;
  R : integer;
begin
  if ServerSocket.Active then
  begin
    ServerSocket.Close;
    btnActivate.Caption := 'Activate';
  end
  else
  begin
    CertStorage.Clear;
    // loading certificate
    if editCert.Text <> '' then
    begin
      F := TFileStream.Create(editCert.Text, fmOpenRead);
      try
        R := Cert.LoadFromStreamPFX(F, editCertPassword.Text);
      finally
        FreeAndNil(F);
      end;
      if R = 0 then
       CertStorage.Add(Cert)
      else
        MessageDlg('Failed to load certificate (error ' + IntToStr(R) + '), continuing without it',
          mtWarning, [mbOk], 0);
    end;
    // configuring versions
    ServerSocket.Versions := [];
    if cbSSL2.Checked then
      ServerSocket.Versions := ServerSocket.Versions + [sbSSL2];
    if cbSSL3.Checked then
      ServerSocket.Versions := ServerSocket.Versions + [sbSSL3];
    if cbTLS1.Checked then
      ServerSocket.Versions := ServerSocket.Versions + [sbTLS1];
    if cbTLS11.Checked then
      ServerSocket.Versions := ServerSocket.Versions + [sbTLS11];
    // configuring port
    ServerSocket.Port := StrToInt(editPort.Text);
    ServerSocket.CompressionAlgorithms[SSL_CA_ZLIB]:=cbCompression.Checked;
    // starting server
    ServerSocket.Open;
    btnActivate.Caption := 'Shutdown';
  end;
end;

procedure TfrmMain.btnBrowseClick(Sender: TObject);
begin
  if OpenDialog.Execute then
    editCert.Text := OpenDialog.Filename;
end;

procedure TfrmMain.ServerSocketAccept(Sender: TObject;
  Socket: TCustomWinSocket);
begin
  Log('Connection request accepted');
end;

procedure TfrmMain.ServerSocketCiphersNegotiated(Sender: TObject);
begin
  Log('New ciphers were negotiated');
end;

procedure TfrmMain.ServerSocketError(Sender: TObject; ErrorCode: Integer;
  Fatal, Remote: Boolean);
begin
  Log('SSL error: ' + IntToStr(ErrorCode));
end;

procedure TfrmMain.ServerSocketClientConnect(Sender: TObject;
  Socket: TCustomWinSocket);
var
  Item : TListItem;
begin
  Log('TCP connection established');
  Item := lvConnections.Items.Add();
  Item.Caption := Socket.RemoteAddress;
  Item.SubItems.Add(TimeToStr(Now));
  Item.SubItems.Add('Establishing...');
  Item.Data := Socket;
end;

procedure TfrmMain.ServerSocketClientDisconnect(Sender: TObject;
  Socket: TCustomWinSocket);
var
  I : integer;
begin
  for I := 0 to lvConnections.Items.Count - 1 do
    if lvConnections.Items[I].Data = Socket then
    begin
      lvConnections.Items.Delete(I);
      Break;
    end;
  Log('TCP connection closed');
end;

procedure TfrmMain.ServerSocketSecureClientConnect(Sender: TObject;
  Socket: TElSecureServerClientWinSocket);
var
  S : string;
  Item : TListItem;
  I : integer;
begin
  Item := nil;
  for I := 0 to lvConnections.Items.Count - 1 do
    if lvConnections.Items[I].Data = Socket then
    begin
      Item := lvConnections.Items[I];
      Break;
    end;
  if Assigned(Item) then
  begin
    case TElSecureServerClientWinSocket(Socket).Version of
      sbSSL2 : S := 'SSLv2';
      sbSSL3 : S := 'SSLv3';
      sbTLS1 : S := 'TLSv1';
      sbTLS11 : S := 'TLSv1.1';
    else
      S := 'Unknown';
    end;
    Item.SubItems[1] := S;
  end;
end;

procedure TfrmMain.btnTerminateClick(Sender: TObject);
begin
  if (lvConnections.Selected <> nil) and (lvConnections.Selected.Data <> nil) then
    TElSecureServerClientWinSocket(lvConnections.Selected.Data).Close;
end;

procedure TfrmMain.ServerSocketClientRead(Sender: TObject;
  Socket: TElSecureServerClientWinSocket);
begin
  Socket.SendText('HTTP/1.0 200 OK'#13#10'Content-Type: text/plain'#13#10#13#10'Welcome to SecureBlackbox ElSecureServerSocket demo!');
end;

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

end.