mainform.pas

著名的SecureBlackBox控件完整源码

unit MainForm;

interface

// remember to install one of additional packages,
// located in <SecureBlackbox>\Classes\ICS,
// as described in SecureBlackbox readme file

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, SBICSServerSocket, SBCustomCertStorage, SBWinCertStorage,
  SBUtils, SBSessionPool, SBX509, SBServer, WSocket, WSocketS, SBConstants;

type
  TForm1 = class(TForm)
    GroupBox1: TGroupBox;
    CheckBox1: TCheckBox;
    CheckBox2: TCheckBox;
    CheckBox3: TCheckBox;
    GroupBox2: TGroupBox;
    Edit1: TEdit;
    GroupBox3: TGroupBox;
    CheckBox4: TCheckBox;
    CheckBox5: TCheckBox;
    CheckBox6: TCheckBox;
    CheckBox7: TCheckBox;
    CheckBox8: TCheckBox;
    CheckBox9: TCheckBox;
    CheckBox10: TCheckBox;
    Memo1: TMemo;
    GroupBox4: TGroupBox;
    Edit2: TEdit;
    Button1: TButton;
    btnStart: TButton;
    GroupBox5: TGroupBox;
    CheckBox11: TCheckBox;
    Edit4: TEdit;
    Label3: TLabel;
    OpenDialog1: TOpenDialog;
    RadioButton1: TRadioButton;
    RadioButton2: TRadioButton;
    cbTLS11: TCheckBox;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
    procedure btnStartClick(Sender: TObject);
    procedure RadioButton1Click(Sender: TObject);
    procedure RadioButton2Click(Sender: TObject);
  private
    { Private declarations }
  public
    procedure Log(const S : string);
    procedure HandleCertificateValidate(Sender : TObject; X509Certificate : TElX509Certificate;
      Socket : TElSecureWSocketClient; var Validate : boolean);
    procedure HandleClientConnect(Sender : TObject; Client : TWSocketClient; Error : word);
    procedure HandleClientCreate(Sender : TObject; Client : TWSocketClient);
    procedure HandleDataAvailable(Sender : TObject; Error : word);
  end;

var
  Form1: TForm1;
  SecureSocket : TElSecureWSocketServer;
  CertStorage : TElMemoryCertStorage;
  ClientCertStorage : TElWinCertStorage;
  SessionPool : TElSessionPool;
  TmpX509Cert : TElX509Certificate;

implementation

{$R *.dfm}

{$R cert.res}

var
  FilterIndex : integer;

function FormatName(const Name: TName): string;
begin
  Result := '';
  if Name.Country <> '' then
    Result := Result + 'C=' + Name.Country + '; ';
  if Name.StateOrProvince <> '' then
    Result := Result + 'SP=' + Name.StateOrProvince + '; ';
  if Name.Locality <> '' then
    Result := Result + 'L=' + Name.Locality + '; ';
  if Name.Organization <> '' then
    Result := Result + 'O=' + Name.Organization + '; ';
  if Name.OrganizationUnit <> '' then
    Result := Result + 'OU=' + Name.OrganizationUnit + '; ';
  if Name.CommonName <> '' then
    Result := Result + 'CN=' + Name.CommonName + '; ';
  if Name.EMailAddress <> '' then
    Result := Result + 'E=' + Name.EMailAddress + '; ';
  if Length(Result) > 0 then
    Result := Copy(Result, 1, Length(Result) - 2);
end;

procedure TForm1.HandleCertificateValidate(Sender : TObject; X509Certificate : TElX509Certificate;
  Socket : TElSecureWSocketClient; var Validate : boolean);
var
  S : string;
  Validity : TSBCertificateValidity;
  Reason : TSBCertificateValidityReason;
begin
  Log('Certificate arrived');
  Log('---Certificate data start---');
  Socket.InternalValidate(Validity, Reason);
  case Validity of
    cvOk : S := 'Certificate is valid';
    cvSelfSigned : S := 'Certificate is self-signed';
    cvInvalid : S := 'Certificate is invalid';
  else
    S := 'Storage error occured while processing certificate';
  end;
  Log(S);
  S := '';
  if vrBadData in Reason then
    S := S + 'Certificate data is corrupt. ';
  if vrRevoked in Reason then
    S := S + 'Certificate is revoked. ';
  if vrNotYetValid in Reason then
    S := S + 'Certificate is not yet valid. ';
  if vrExpired in Reason then
    S := S + 'Certificate is expired. ';
  if vrInvalidSignature in Reason then
    S := S + 'Certificate contains invalid digital signature. ';
  if vrUnknownCA in Reason then
    S := S + 'Certificate is signed by unknown CA. ';
  Log(S);
  S := 'ISSUER: ' + FormatName(X509Certificate.IssuerName);
  Log(S);
  S := 'SUBJECT: ' + FormatName(X509Certificate.SubjectName);
  Log(S);
  Log('---Certificate data end---');
end;

procedure TForm1.HandleClientCreate(Sender : TObject; Client : TWSocketClient);
begin
  Client.OnDataAvailable := HandleDataAvailable;
end;

procedure TForm1.HandleClientConnect(Sender : TObject; Client : TWSocketClient; Error : word);
var
  S : string;
begin
  Log('Client connected');
  case TElSecureWSocketClient(Client).Version of
    sbSSL2 : S := 'Version: SSL2, ';
    sbSSL3 : S := 'Version: SSL3, ';
    sbTLS1 : S := 'Version: TLS1, ';
    sbTLS11 : S := 'Version: TLS1.1, ';
  end;
  case TElSecureWSocketClient(Client).CipherSuite of
    SB_SUITE_RSA_RC4_MD5 : S := S + 'CipherSuite: RSA-RC4-MD5';
    SB_SUITE_RSA_RC4_MD5_EXPORT : S := S + 'CipherSuite: RSA-RC4-MD5-EXP';
    SB_SUITE_RSA_3DES_SHA : S := S + 'CipherSuite: RSA-3DES-SHA';
    SB_SUITE_DHE_RSA_3DES_SHA : S := S + 'CipherSuite: DHE-RSA-3DES-SHA';
    SB_SUITE_DH_RSA_3DES_SHA : S := S + 'CipherSuite: DH-RSA-3DES-SHA';
    SB_SUITE_DH_ANON_RC4_MD5 : S := S + 'CipherSuite: DH-ANON-RC4-MD5';
    SB_SUITE_RSA_AES256_SHA : S := S + 'CipherSuite: RSA-AES256-SHA';
  else
    S := S + 'CipherSuite: Unknown'; 
  end;
  Log('SecureParameters are: ' + S);
end;

procedure TForm1.HandleDataAvailable(Sender : TObject; Error : word);
var
  S : string;
begin
  S := TElSecureWSocketClient(Sender).ReceiveStr;
  S := 'Data received from client: ' + S;
  Log(S);

  S := 'HTTP/1.1 200 OK'#13#10'Connection: close'#13#10#13#10'<html><body>Simple server</body></html>';
  TElSecureWSocketClient(Sender).Send(@S[1], Length(S));
  TElSecureWSocketClient(Sender).Close;
end;

procedure TForm1.Log(const S : string);
begin
  Memo1.Lines.Text := Memo1.Lines.Text + S + #13#10;
end;

procedure TForm1.FormCreate(Sender: TObject);
var
  Stream : TResourceStream;
  I : integer;
begin
  SecureSocket := TElSecureWSocketServer.Create(Self);
  CertStorage := TElMemoryCertStorage.Create(Self);
  ClientCertStorage := TElWinCertStorage.Create(Self);
  SessionPool := TElSessionPool.Create(Self);
  TmpX509Cert := TElX509Certificate.Create(nil);
  SecureSocket.OnCertificateValidate := HandleCertificateValidate;
  SecureSocket.OnClientConnect := HandleClientConnect;
  SecureSocket.OnClientCreate := HandleClientCreate;
  Stream := TResourceStream.CreateFromId(HINSTANCE, 103, PChar('CERTIFICATE'));
  try
    I := TmpX509Cert.LoadFromStreamPFX(Stream, 'password');
  finally
    Stream.Free;
  end;
  if I <> 0 then
  begin
    ShowMessage('Error loading internal certificate');
    Form1.Close;
  end;
  CertStorage.Add(TmpX509Cert);
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  SecureSocket.Close;
  CertStorage.Free;
  ClientCertStorage.Free;
  SessionPool.Free;
  SecureSocket.Free;
  TmpX509Cert.Free;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  if OpenDialog1.Execute then
  begin
    Edit2.Text := OpenDialog1.FileName;
    FilterIndex := OpenDialog1.FilterIndex;
  end;
end;

procedure TForm1.Button3Click(Sender: TObject);
begin
  CertStorage.Add(TmpX509Cert);
  Edit2.Text := '';
end;

procedure TForm1.btnStartClick(Sender: TObject);
var
  Cert : TElX509Certificate;
  F : TFileStream;
  Password : string;
  I : integer;
begin
  if SecureSocket.State = wsClosed then
  begin
    while CertStorage.Count > 0 do
      CertStorage.Remove(0);
    if RadioButton1.Checked then
      CertStorage.Add(TmpX509Cert)
    else
    if Length(Edit2.Text) > 0 then
    begin
      Cert := TElX509Certificate.Create(nil);
      F := TFileStream.Create(Edit2.Text, fmOpenRead);
      Password := InputBox('Password for Certificate', 'Please enter the passphrase to decrypt certificate', '');
      if FilterIndex = 1 then
        I := Cert.LoadFromStreamPEM(F, Password)
      else
        I := Cert.LoadFromStreamPFX(F, Password);
      if I = 0 then
        CertStorage.Add(Cert)
      else
        MessageDlg('Invalid security certificate', mtError, [mbOk], 0);
      Cert.Free;
    end;
    if CheckBox1.Checked then
      SecureSocket.Versions := SecureSocket.Versions + [sbSSL2];
    if CheckBox2.Checked then
      SecureSocket.Versions := SecureSocket.Versions + [sbSSL3];
    if CheckBox3.Checked then
      SecureSocket.Versions := SecureSocket.Versions + [sbTLS1];
    if cbTLS11.Checked then
      SecureSocket.Versions := SecureSocket.Versions + [sbTLS11];
    if CheckBox4.Checked then
      SecureSocket.CipherSuites[SB_SUITE_RSA_RC4_MD5] := true;
    if CheckBox5.Checked then
      SecureSocket.CipherSuites[SB_SUITE_RSA_RC4_MD5_EXPORT] := true;
    if CheckBox6.Checked then
      SecureSocket.CipherSuites[SB_SUITE_RSA_3DES_SHA] := true;
    if CheckBox7.Checked then
      SecureSocket.CipherSuites[SB_SUITE_DHE_RSA_3DES_SHA] := true;
    if CheckBox8.Checked then
      SecureSocket.CipherSuites[SB_SUITE_DH_RSA_3DES_SHA] := true;
    if CheckBox9.Checked then
      SecureSocket.CipherSuites[SB_SUITE_DH_ANON_RC4_MD5] := true;
    if CheckBox10.Checked then
      SecureSocket.CipherSuites[SB_SUITE_RSA_AES256_SHA] := true;
    if CheckBox11.Checked then
      SecureSocket.ClientAuthentication := true;
    ClientCertStorage.SystemStores.Clear;
    ClientCertStorage.SystemStores.Add(Edit4.Text);
    SecureSocket.CertStorage := CertStorage;
    SecureSocket.ClientCertStorage := ClientCertStorage;
    SecureSocket.SessionPool := SessionPool;
    SecureSocket.Addr := 'localhost';
    SecureSocket.Port := Edit1.Text;
    Log('Starting server socket');
    SecureSocket.Listen;
    btnStart.Caption := 'Stop listening';
    Log('Server socket started');
  end
  else
  begin
    Log('Stopping server socket');
    SecureSocket.Close;
    btnStart.Caption := 'Start listening';
    Log('Server socket stopped');
  end;

end;

procedure TForm1.RadioButton1Click(Sender: TObject);
begin
  Edit2.Enabled := false;
  Button1.Enabled := false;
end;

procedure TForm1.RadioButton2Click(Sender: TObject);
begin
  Edit2.Enabled := true;
  Button1.Enabled := true;
end;

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

end.