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, IdBaseComponent,
  IdContext, IdComponent, IdTCPServer, IdHTTPServer, IdCustomHTTPServer,
  IdServerIOHandler, IdServerIOHandlerSocket, SBConstants, IdSSL,
  SBIndyServerIOHandler10;

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;
    HTTPServer: TIdHTTPServer;
    SessionPool: TElSessionPool;
    ClientCertStorage: TElWinCertStorage;
    CertStorage: TElMemoryCertStorage;
    IOHandler: TElIndySSLServerIOHandler;
    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 HTTPServerCommandGet(AContext: TIdContext;
      ARequestInfo: TIdHTTPRequestInfo;
      AResponseInfo: TIdHTTPResponseInfo);
    procedure IOHandlerCertificateValidate(Sender: TObject;
      X509Certificate: TElX509Certificate;
      IOHandler: TElClientServerIndySSLIOHandlerSocket;
      var Validate: Boolean);
  private
    { Private declarations }
  public
    procedure Log(const S : string);
  end;

var
  Form1: TForm1;
  TmpX509Cert : TElX509Certificate;

implementation

{$R *.dfm}

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);
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  TmpX509Cert.Free;
  HTTPServer.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.Add(TmpX509Cert);
  Edit2.Text := '';
  Edit3.Text := '';
end;

procedure TForm1.Button4Click(Sender: TObject);
begin
  if HTTPServer.Active then
  begin
    HTTPServer.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);
	  HTTPServer.DefaultPort := StrToInt(Edit1.Text);
	  Log('Starting HTTPS server');
	  HTTPServer.Active := true;
	  Log('HTTPS server started');
  end;
end;

procedure TForm1.HTTPServerCommandGet(AContext: TIdContext;
  ARequestInfo: TIdHTTPRequestInfo; AResponseInfo: TIdHTTPResponseInfo);
begin
  Log('Get Command Arrived. Sending response and closing.');
  AResponseInfo.ContentText := '12345';
end;

procedure TForm1.IOHandlerCertificateValidate(Sender: TObject;
  X509Certificate: TElX509Certificate;
  IOHandler: TElClientServerIndySSLIOHandlerSocket; 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('---Certificate data end---');
  Validate := true;
end;

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

end.