mainform.pas

著名的SecureBlackBox控件完整源码

unit MainForm;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, ExtCtrls, ComCtrls, ToolWin, Menus, ImgList, SBClient, SBSimpleSSL,
  SBUtils, SBConstants, SBX509, SBCustomCertStorage, SBWinCertStorage;

type
  TfrmMain = class(TForm)
    lvLog: TListView;
    Splitter: TSplitter;
    pClient: TPanel;
    memoOutput: TMemo;
    tbToolbar: TToolBar;
    btnConnect: TToolButton;
    btnDisconnect: TToolButton;
    MainMenu: TMainMenu;
    mnuConnection: TMenuItem;
    mnuConnect: TMenuItem;
    mnuDisconnect: TMenuItem;
    mnuBreak: TMenuItem;
    mnuExit: TMenuItem;
    mnuHelp: TMenuItem;
    mnuAbout: TMenuItem;
    imgToolbar: TImageList;
    imgLog: TImageList;
    ElWinCertStorage: TElWinCertStorage;
    ElMemoryCertStorage: TElMemoryCertStorage;
    procedure btnConnectClick(Sender: TObject);
    procedure btnDisconnectClick(Sender: TObject);
    procedure mnuConnectClick(Sender: TObject);
    procedure mnuDisconnectClick(Sender: TObject);
    procedure mnuExitClick(Sender: TObject);
    procedure mnuAboutClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
  private
    FClient : TElSimpleSSLClient;
    FCert : TElX509Certificate;
    FUseCert : boolean;
    FNeededIndex : integer;
    procedure Log(const S: string; Error: boolean);
    procedure SetupEvents;
    procedure InitializeApp;
    procedure FinalizeApp;
    procedure Connect;
    procedure DoRequest;
    procedure Disconnect;
    procedure ExitApp;
    procedure ShowAbout;


    procedure ClientCertificateValidate(Sender: TObject; Cert : TElX509Certificate;
        var Validate : boolean);
    procedure ClientCertificateNeededEx(Sender: TObject; var Certificate:
        TElX509Certificate);
  public
    { Public declarations }
  end;

var
  frmMain: TfrmMain;

implementation

uses ConnPropsForm, AboutForm, SBSSLConstants;

{$R *.DFM}

procedure TfrmMain.Log(const S: string; Error: boolean);
var
  Item : TListItem;
begin
  Item := lvLog.Items.Add;
  Item.Caption := TimeToStr(Now);
  Item.SubItems.Add(S);
  if Error then
    Item.ImageIndex := 1
  else
    Item.ImageIndex := 0;
end;

procedure TfrmMain.btnConnectClick(Sender: TObject);
begin
  Connect;
end;

procedure TfrmMain.btnDisconnectClick(Sender: TObject);
begin
  Disconnect;
end;

procedure TfrmMain.mnuConnectClick(Sender: TObject);
begin
  Connect;
end;

procedure TfrmMain.mnuDisconnectClick(Sender: TObject);
begin
  Disconnect;
end;

procedure TfrmMain.mnuExitClick(Sender: TObject);
begin
  ExitApp;
end;

procedure TfrmMain.mnuAboutClick(Sender: TObject);
begin
  ShowAbout;
end;

procedure TfrmMain.Connect;
var
  F : TFileStream;
  R : integer;
begin
  if FClient.Active then
  begin
    MessageDlg('Already connected, please disconnect first', mtWarning, [mbOk], 0);
    Exit;
  end;

  if frmConnProps.ShowModal = mrOk then
  begin
    FClient.Address := frmConnProps.editHost.Text;
    FClient.CompressionAlgorithms[SSL_CA_ZLIB]:=frmConnProps.cbCompression.Checked;
    FClient.Port := StrToIntDef(frmConnProps.editPort.Text, 443);
    FClient.Versions := [];
    if frmConnProps.cbSSL2.Checked then
      FClient.Versions := FClient.Versions + [sbSSL2];
    if frmConnProps.cbSSL3.Checked then
      FClient.Versions := FClient.Versions + [sbSSL3];
    if frmConnProps.cbTLS1.Checked then
      FClient.Versions := FClient.Versions + [sbTLS1];
    if frmConnProps.cbTLS11.Checked then
      FClient.Versions := FClient.Versions + [sbTLS11];
    FUseCert := false;
    if (frmConnProps.editCert.Text <> '') and (FileExists(frmConnProps.editCert.Text)) then
    begin
      try
        F := TFileStream.Create(frmConnProps.editCert.Text, fmOpenRead);
        try
          R := FCert.LoadFromStreamPFX(F, frmConnProps.editPassword.Text);
          if R = 0 then
          begin
            FUseCert := true;
            Log('Certificate loaded OK', false);
          end
          else
            Log('Failed to load certificate, PFX error ' + IntToHex(R, 4), true);
        finally
          F.Free;
        end;
      except
        on E: Exception do
          Log(E.Message, true);
      end;
    end;
    Log('Connecting to ' + FClient.Address + ':' + IntToStr(FClient.Port), false);
    FClient.Enabled := not frmConnProps.cbClear.Checked;

    FNeededIndex := 0;
    ElMemoryCertStorage.Clear;
    memoOutput.Clear;
    lvLog.Items.Clear;
    DoRequest;
  end;
end;

procedure TfrmMain.DoRequest;
var
  S: string;
  Read: integer;
begin
  try
    //FClient.SocketTimeout := 10000;
    FClient.Open;
    if not FClient.Active then
    begin
      Log('Failed to establish connection', true);
      exit;
    end;
  except
    on E: Exception do
    begin
      Log('Failed to establish connection: ' + E.Message, true);
      Exit;
    end;
  end;

  Log('SSL connection established', false);
  case FClient.CurrentVersion of
    sbSSL2 : S := 'SSL2';
    sbSSL3 : S := 'SSL3';
    sbTLS1 : S := 'TLS1';
    sbTLS11 : S := 'TLS1.1';
  else
    S := 'Unknown';
  end;
  Log('Version is ' + S, false);
  Log('Sending HTTP request in encrypted form', false);

  S := 'GET / HTTP/1.0'#13#10'Connection: close'#13#10#13#10;
  FClient.SendText(S);

  while FClient.Active do
  begin
    Read := $FFFF;
    SetLength(S, Read);
    try
      FClient.ReceiveData(@S[1], Read);
      SetLength(S, Read);
      memoOutput.Lines.Text := memoOutput.Lines.Text + S;
    except
      // here we can catch disconnection or timeout event or something like this
      break;
    end;
    Application.ProcessMessages;
  end;
  Disconnect
end;

procedure TfrmMain.Disconnect;
begin
  if FClient.Active then
  begin
    Log('Disconnecting', false);
  end;
  FClient.Close;
end;

procedure TfrmMain.ExitApp;
begin
  Self.Close;
end;

procedure TfrmMain.ShowAbout;
begin
  frmAbout.ShowModal;
end;

procedure TfrmMain.InitializeApp;
begin
  FClient := TElSimpleSSLClient.Create(nil);
  FCert := TElX509Certificate.Create(nil);
  SetupEvents;
  FClient.CertStorage := ElWinCertStorage;
end;

procedure TfrmMain.FinalizeApp;
begin
  FCert.Free;
  FClient.Free;
end;

procedure TfrmMain.SetupEvents;
begin
  FClient.OnCertificateValidate := ClientCertificateValidate;
  FClient.OnCertificateNeededEx := ClientCertificateNeededEx;
end;

procedure TfrmMain.FormCreate(Sender: TObject);
begin
  InitializeApp;
end;

procedure TfrmMain.FormDestroy(Sender: TObject);
begin
  FinalizeApp;
end;

procedure TfrmMain.ClientCertificateValidate(Sender: TObject; Cert :
    TElX509Certificate; var Validate : boolean);
var
  S: string;
  Validity: TSBCertificateValidity;
  Reason: TSBCertificateValidityReason;
begin
  Log('Certificate received', false);
  S := 'Issuer: ' + 'CN=' + Cert.IssuerName.CommonName + ', C=' + Cert.IssuerName.Country +
    ', O=' + Cert.IssuerName.Organization + ', L=' + Cert.IssuerName.Locality;
  Log(S, false);
  S := 'Subject: ' + 'CN=' + Cert.SubjectName.CommonName + ', C=' + Cert.SubjectName.Country +
    ', O=' + Cert.SubjectName.Organization + ', L=' + Cert.SubjectName.Locality;
  Log(S, false);
  FClient.InternalValidate(Validity, Reason);
  if not (Validity in [cvOk, cvSelfSigned]) then
  begin
    Validity := ElMemoryCertStorage.Validate(Cert, Reason);
    if not (Validity in [cvOk, cvSelfSigned]) then
      Log('Warning: certificate is not valid!', true)
    else
      Log('Certificate is OK', false);
  end
  else
    Log('Certificate is OK', false);
  // adding certificate to temporary store
  ElMemoryCertStorage.Add(Cert);
  Validate := true;
end;

procedure TfrmMain.ClientCertificateNeededEx(Sender: TObject; var Certificate:
    TElX509Certificate);
begin
  if (FUseCert) and (FNeededIndex = 0) then
  begin
    Certificate := FCert;
    Inc(FNeededIndex);
  end
  else
  begin
    Certificate := nil;
  end;
end;

procedure TfrmMain.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
  Disconnect;
  CanClose := true;
end;


initialization

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

end.