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, SBIndySSLServerIOHandler, IdBaseComponent,
  IdComponent, IdTCPServer, IdHTTPServer, IdCustomHTTPServer,
  IdServerIOHandler, IdServerIOHandlerSocket, 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;
    IOHandler: TElIndySSLServerIOHandler;
    SessionPool: TElSessionPool;
    ClientCertStorage: TElWinCertStorage;
    CertStorage: TElMemoryCertStorage;
    cbTLS11: TCheckBox;
    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;
      IOHandler : TElIndySSLIOHandlerServerSocket; var Validate : boolean);
  end;

var
  Form1: TForm1;
  TmpX509Cert : TElX509Certificate;

implementation

{$R *.dfm}

procedure TForm1.HandleCertificateValidate(Sender : TObject; X509Certificate : TElX509Certificate;
  IOHandler : TElIndySSLIOHandlerServerSocket; var Validate : boolean);
var
  S : string;
  Validity : TSBCertificateValidity;
  Reason : TSBCertificateValidityReason;
begin
  Log('Certificate arrived');
  Log('---Certificate data start---');
  IOHandler.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: ' + 'CN=' + X509Certificate.IssuerName.CommonName + ', C=' + X509Certificate.IssuerName.Country +
    ', O=' + X509Certificate.IssuerName.Organization + ', L=' + X509Certificate.IssuerName.Locality;
  Log(S);
  S := 'Subject: ' + 'CN=' + X509Certificate.SubjectName.CommonName + ', C=' + X509Certificate.SubjectName.Country +
    ', O=' + X509Certificate.SubjectName.Organization + ', L=' + X509Certificate.SubjectName.Locality;
  Log(S);Log('---Certificate data end---');
  Validate := true;
end;

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

procedure TForm1.FormCreate(Sender: TObject);
begin
  TmpX509Cert := TElX509Certificate.Create(nil);
  IOHandler.OnCertificateValidate := HandleCertificateValidate;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  TmpX509Cert.Free;
  IdHTTPServer1.Active := false;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  Buffer : array of byte;
  F : TStream;
  I : integer;
begin
  if OpenDialog1.Execute then
  begin
    F := TFileStream.Create(OpenDialog1.FileName, fmOpenRead or fmShareDenyWrite);
    try
      I := F.Size;
      SetLength(Buffer, I);
      F.ReadBuffer(Buffer[0], I);
      TmpX509Cert.LoadFromBuffer(@Buffer[0], I);
      Edit2.Text := OpenDialog1.FileName;
    finally
      F.Free;
    end;
  end;
end;

procedure TForm1.Button2Click(Sender: TObject);
var
  Buffer : array of byte;
  F : TStream;
  I : integer;
begin
  if OpenDialog1.Execute then
  begin
    F := TFileStream.Create(OpenDialog1.FileName, fmOpenRead or fmShareDenyWrite);
    try
      I := F.Size;
      SetLength(Buffer, I);
      F.ReadBuffer(Buffer[0], I);
      if TmpX509Cert.LoadKeyFromBufferPEM(@Buffer[0], F.Size, '123456') <> 0 then
        TmpX509Cert.LoadKeyFromBuffer(@Buffer[0], I);
      Edit3.Text := OpenDialog1.FileName;
    finally
      F.Free;
    end;
  end;
end;

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

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

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

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

end.