unit1.pas

著名的SecureBlackBox控件完整源码

unit Unit1;

interface

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

uses
  Windows, SysUtils, Classes, Controls, Forms, Dialogs, StdCtrls,
  HttpProt, WSocket, SBClient, SBWSocket, SBHttpsCli, SBConstants,
  SBUtils, SBX509, Graphics;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Memo1: TMemo;
    Button3: TButton;
    Label1: TLabel;
    Button2: TButton;
    GroupBox1: TGroupBox;
    CheckBox1: TCheckBox;
    CheckBox2: TCheckBox;
    CheckBox3: TCheckBox;
    GroupBox2: TGroupBox;
    OpenDialog1: TOpenDialog;
    ComboBox1: TComboBox;
    ElHttpsCli1: TElHttpsCli;
    ElSecureWSocket1: TElSecureWSocket;
    ButtonCert: TButton;
    LabelStatus: TLabel;
    Label2: TLabel;
    CheckBox4: TCheckBox;
    procedure Button1Click(Sender: TObject);
    procedure SSLWSocket1SessionConnected(Sender: TObject; Error: Word);
    procedure SSLWSocket1DataAvailable(Sender: TObject; Error: Word);
    procedure Button3Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure CheckBox1Click(Sender: TObject);
    procedure CheckBox2Click(Sender: TObject);
    procedure CheckBox3Click(Sender: TObject);
    procedure ElHttpsCli1HeaderData(Sender: TObject);
    procedure ElHttpsCli1DocData(Sender: TObject; Buffer: Pointer;
      Len: Integer);
    procedure ElHttpsCli1HeaderEnd(Sender: TObject);
    procedure ButtonCertClick(Sender: TObject);
    procedure ElSecureWSocket1CertificateNeededEx(Sender: TObject;
      var Certificate: TElX509Certificate);
    procedure ElHttpsCli1CertificateValidate(Sender: TObject;
      Certificate: TElX509Certificate; var Validate: Boolean);
    procedure ElSecureWSocket1CertificateValidate(Sender: TObject;
      Certificate: TElX509Certificate; var Validate: Boolean);
    procedure CheckBox4Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;
  Cert: TElX509Certificate;
  CertNeededStage : integer;

implementation

uses PasswordForm;

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);
begin
  Memo1.Clear;
  CertNeededStage := 0;
  ElSecureWSocket1.Close;

  ElSecureWSocket1.Addr := ComboBox1.Text;
  ElSecureWSocket1.Port := '443';
  ElSecureWSocket1.Connect;
end;

procedure TForm1.SSLWSocket1SessionConnected(Sender: TObject; Error: Word);
begin
  ElSecureWSocket1.Send(PChar('GET / HTTP/1.0'#10#10), 18);
end;

procedure TForm1.SSLWSocket1DataAvailable(Sender: TObject; Error: Word);
begin
  Memo1.Lines.Text := Memo1.Lines.Text + ElSecureWSocket1.ReceiveStr;
end;

procedure LoadMemoFromMemoryStream(Memo: TMemo; Stream: TMemoryStream);
var
  p, q, r: PChar;
begin
  p := Stream.Memory;
  q := p + Stream.Size; // -1; fixed by Shay Horovitz
  r := p;
  while (p <> nil) and (p < q) do
  begin
    while (p < q) and (p^ <> #13) and (p^ <> #10) do
      Inc(p);
    Memo.Lines.Add(Copy(StrPas(r), 1, p - r));
    if (p[0] = #13) and (p[1] = #10) then
      Inc(p, 2)
    else
      Inc(p);
    r := p;
  end;
end;

procedure TForm1.Button3Click(Sender: TObject);
begin
  Memo1.Clear;
  CertNeededStage := 0;
  ElHttpsCli1.URL := 'https://' + ComboBox1.Text + ':443/';
  ElHttpsCli1.GetASync;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  Close;
end;

procedure TForm1.CheckBox1Click(Sender: TObject);
begin
  if CheckBox1.Checked then
  begin
    ElSecureWSocket1.Versions := ElSecureWSocket1.Versions + [sbSSL2];
    ElHttpsCli1.Versions := ElHttpsCli1.Versions + [sbSSL2];
  end else
  begin
    ElSecureWSocket1.Versions := ElSecureWSocket1.Versions - [sbSSL2];
    ElHttpsCli1.Versions := ElHttpsCli1.Versions - [sbSSL2];
  end;
end;

procedure TForm1.CheckBox2Click(Sender: TObject);
begin
  if CheckBox2.Checked then
  begin
    ElSecureWSocket1.Versions := ElSecureWSocket1.Versions + [sbSSL3];
    ElHttpsCli1.Versions := ElHttpsCli1.Versions + [sbSSL3];
  end else
  begin
    ElSecureWSocket1.Versions := ElSecureWSocket1.Versions - [sbSSL3];
    ElHttpsCli1.Versions := ElHttpsCli1.Versions - [sbSSL3];
  end;
end;

procedure TForm1.CheckBox3Click(Sender: TObject);
begin
  if CheckBox3.Checked then
  begin
    ElSecureWSocket1.Versions := ElSecureWSocket1.Versions + [sbTLS1];
    ElHttpsCli1.Versions := ElHttpsCli1.Versions + [sbTLS1];
  end else
  begin
    ElSecureWSocket1.Versions := ElSecureWSocket1.Versions - [sbTLS1];
    ElHttpsCli1.Versions := ElHttpsCli1.Versions - [sbTLS1];
  end;
end;

procedure TForm1.CheckBox4Click(Sender: TObject);
begin
  if CheckBox4.Checked then
  begin
    ElSecureWSocket1.Versions := ElSecureWSocket1.Versions + [sbTLS11];
    ElHttpsCli1.Versions := ElHttpsCli1.Versions + [sbTLS11];
  end else
  begin
    ElSecureWSocket1.Versions := ElSecureWSocket1.Versions - [sbTLS11];
    ElHttpsCli1.Versions := ElHttpsCli1.Versions - [sbTLS11];
  end;
end;

procedure TForm1.ElHttpsCli1HeaderData(Sender: TObject);
begin
  Memo1.Lines.Add(ElHttpsCli1.LastResponse);
end;

procedure TForm1.ElHttpsCli1DocData(Sender: TObject; Buffer: Pointer;
  Len: Integer);
begin
  Memo1.Lines.Text := Memo1.Lines.Text + StrPas(Buffer);
end;

procedure TForm1.ElHttpsCli1HeaderEnd(Sender: TObject);
begin
  Memo1.Lines.Add('');
end;

procedure TForm1.ButtonCertClick(Sender: TObject);
var
  F : TFileStream;
  R : integer;
begin
  if Cert = nil then
  begin
    if OpenDialog1.Execute then
    begin
      F := TFileStream.Create(OpenDialog1.Filename, fmOpenRead);
      if FormPassword.ShowModal = mrOk then
      begin
        Cert := TElX509Certificate.Create(nil);
        try
          try
            R := Cert.LoadFromStreamPFX(F, FormPassword.EditPassword.Text);
          finally
            F.Free;
          end;
          if R <> 0 then
          begin
            MessageDlg('Bad certificate or invalid password', mtError, [mbOk], 0);
            FreeAndNil(Cert);
          end;
        except
          FreeAndNil(Cert);
        end;
      end
      else
        F.Free;
    end;
  end
  else
  begin
    FreeAndNil(Cert);
  end;
  if Cert = nil then
  begin
    LabelStatus.Caption := 'Status: no certificate';
    LabelStatus.Font.Color := clBlack;
    ButtonCert.Caption := 'Load';
  end
  else
  begin
    LabelStatus.Caption := 'Status: certificate is loaded';
    LabelStatus.Font.Color := clBlue;
    ButtonCert.Caption := 'Remove';
  end;
end;

procedure TForm1.ElSecureWSocket1CertificateNeededEx(Sender: TObject;
  var Certificate: TElX509Certificate);
begin
  if (CertNeededStage = 0) and (Cert <> nil) then
  // this is a first call to OnCertificateNeededEx, passing our certificate
  begin
    Certificate := Cert;
    CertNeededStage := 1;
  end
  else
  // no certificate present, or it is a second call to OnCertificateNeededEx
  begin
    Certificate := nil;
  end;
end;

procedure TForm1.ElHttpsCli1CertificateValidate(Sender: TObject;
  Certificate: TElX509Certificate; var Validate: Boolean);
begin
  Validate := true;
  // NEVER do this in real life since this makes security void. 
  // Instead validate the certificate as described on http://www.eldos.com/sbb/articles/1966.php
end;

procedure TForm1.ElSecureWSocket1CertificateValidate(Sender: TObject;
  Certificate: TElX509Certificate; var Validate: Boolean);
begin
  Validate := true;
  // NEVER do this in real life since this makes security void. 
  // Instead validate the certificate as described on http://www.eldos.com/sbb/articles/1966.php
end;

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

end.