mainform.pas

著名的SecureBlackBox控件完整源码

unit MainForm;

interface

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

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, SBUtils, SBCustomCertStorage, SBWinCertStorage,
  SBSessionPool, SBX509, SBServer, SBServerIndyIntercept, IdBaseComponent,
  IdComponent, IdTCPServer, IdHTTPServer, 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;
    Edit3: TEdit;
    Button2: TButton;
    Label1: TLabel;
    Label2: TLabel;
    Button3: TButton;
    Button4: TButton;
    GroupBox5: TGroupBox;
    CheckBox11: TCheckBox;
    Edit4: TEdit;
    Label3: TLabel;
    OpenDialog1: TOpenDialog;
    IdHTTPServer1: TIdHTTPServer;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
    procedure Button4Click(Sender: TObject);
    procedure IdHTTPServer1CommandGet(AThread: TIdPeerThread;
      RequestInfo: TIdHTTPRequestInfo; ResponseInfo: TIdHTTPResponseInfo);
  private
    { Private declarations }
  public
    procedure Log(const S : string);
    procedure HandleCertificateValidate(Sender : TObject; X509Certificate : TElX509Certificate;
      Intercept : TElIndyConnectionSSLServerIntercept; var Validate : boolean);
  end;

var
  Form1: TForm1;
  Intercept : TElIndyServerSSLIntercept;
  CertStorage : TElMemoryCertStorage;
  ClientCertStorage : TElWinCertStorage;
  SessionPool : TElSessionPool;
  TmpX509Cert : TElX509Certificate;

implementation

{$R *.dfm}

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;
  Intercept : TElIndyConnectionSSLServerIntercept; var Validate : boolean);
var
  S : string;
  Validity : TSBCertificateValidity;
  Reason : TSBCertificateValidityReason;
begin
  Log('Certificate arrived');
  Log('---Certificate data start---');
  Intercept.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.Log(const S : string);
begin
  Memo1.Lines.Text := Memo1.Lines.Text + S + #13#10;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  Intercept := TElIndyServerSSLIntercept.Create(Self);
  CertStorage := TElMemoryCertStorage.Create(Self);
  ClientCertStorage := TElWinCertStorage.Create(Self);
  SessionPool := TElSessionPool.Create(Self);
  TmpX509Cert := TElX509Certificate.Create(nil);
  Intercept.OnCertificateValidate := HandleCertificateValidate;
end;

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

procedure TForm1.Button1Click(Sender: TObject);
var
  Buffer : array[0..4095] of byte;
  F : file;
  I : integer;
begin
  if OpenDialog1.Execute then
  begin
    AssignFile(F, OpenDialog1.FileName);
    Reset(F, 1);
    I := 0;
    while not Eof(F) do
    begin
      BlockRead(F, Buffer[I], 1);
      Inc(I);
    end;
    TmpX509Cert.LoadFromBuffer(@Buffer[0], I);
    Edit2.Text := OpenDialog1.FileName;
  end;
end;

procedure TForm1.Button2Click(Sender: TObject);
var
  Buffer : array[0..4095] of byte;
  F : file;
  I : integer;
begin
  if OpenDialog1.Execute then
  begin
    AssignFile(F, OpenDialog1.FileName);
    Reset(F, 1);
    I := 0;
    while not Eof(F) do
    begin
      BlockRead(F, Buffer[I], 1);
      Inc(I);
    end;
    TmpX509Cert.LoadKeyFromBuffer(@Buffer[0], I);
    Edit3.Text := OpenDialog1.FileName;
  end;
end;

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

procedure TForm1.Button4Click(Sender: TObject);
begin
  if CheckBox1.Checked then
    Intercept.Versions := Intercept.Versions + [sbSSL2];
  if CheckBox2.Checked then
    Intercept.Versions := Intercept.Versions + [sbSSL3];
  if CheckBox3.Checked then
    Intercept.Versions := Intercept.Versions + [sbTLS1];
  if CheckBox4.Checked then
    Intercept.CipherSuites[SB_SUITE_RSA_RC4_MD5] := true;
  if CheckBox5.Checked then
    Intercept.CipherSuites[SB_SUITE_RSA_RC4_MD5_EXPORT] := true;
  if CheckBox6.Checked then
    Intercept.CipherSuites[SB_SUITE_RSA_3DES_SHA] := true;
  if CheckBox7.Checked then
    Intercept.CipherSuites[SB_SUITE_DHE_RSA_3DES_SHA] := true;
  if CheckBox8.Checked then
    Intercept.CipherSuites[SB_SUITE_DH_RSA_3DES_SHA] := true;
  if CheckBox9.Checked then
    Intercept.CipherSuites[SB_SUITE_DH_ANON_RC4_MD5] := true;
  if CheckBox10.Checked then
    Intercept.CipherSuites[SB_SUITE_RSA_AES256_SHA] := true;
  if CheckBox11.Checked then
    Intercept.ClientAuthentication := true;
  ClientCertStorage.SystemStores.Clear;
  ClientCertStorage.SystemStores.Add(Edit4.Text);
  Intercept.CertStorage := CertStorage;
  Intercept.ClientCertStorage := ClientCertStorage;
  Intercept.SessionPool := SessionPool;
  IdHTTPServer1.Intercept := Intercept;
  Log('Starting HTTPS server');
  IdHTTPServer1.Active := true;
end;

procedure TForm1.IdHTTPServer1CommandGet(AThread: TIdPeerThread;
  RequestInfo: TIdHTTPRequestInfo; ResponseInfo: TIdHTTPResponseInfo);
begin
  Log('Get Command Arrived. Sending response and closing.');
end;

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


end.