mainform.pas

著名的SecureBlackBox控件完整源码

unit MainForm;

interface

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

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

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
    FClientSocket: TElSecureClientSocket;
    FCert : TElX509Certificate;
    FUseCert : boolean;
    FNeededIndex : integer;
    procedure Log(const S: string; Error: boolean);
    procedure SetupEvents;
    procedure InitializeApp;
    procedure FinalizeApp;
    procedure Connect;
    procedure ConnectBlocking;
    procedure ConnectNonBlocking;
    procedure Disconnect;
    procedure ExitApp;
    procedure ShowAbout;

    procedure ClientSocketCertificateValidate(Sender: TObject;
      Cert : TElX509Certificate; var Validate : boolean);
    procedure ClientSocketCertificateNeededEx(Sender: TObject;
      var Certificate: TElX509Certificate);
    procedure ClientSocketSSLEstablished(Sender : TObject; Version : TSBVersion;
      CipherSuite : TSBCipherSuite);
    procedure ClientSocketSSLClose(Sender: TObject);
    procedure ClientSocketSSLError(Sender: TObject; ErrorCode: integer; Fatal: boolean; Remote : boolean);
    procedure ClientSocketConnect(Sender: TObject; Socket: TCustomWinSocket);
    procedure ClientSocketDisconnect(Sender: TObject; Socket: TCustomWinSocket);
    procedure ClientSocketRead(Sender: TObject; Socket: TCustomWinSocket);
    procedure ClientSocketError(Sender: TObject; Socket: TCustomWinSocket;
      ErrorEvent: TErrorEvent; var ErrorCode: Integer);
  public
    { Public declarations }
  end;

var
  frmMain: TfrmMain;

implementation

uses ConnPropsForm, AboutForm;

{$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 FClientSocket.Active then
  begin
    MessageDlg('Already connected, please disconnect first', mtWarning, [mbOk], 0);
    Exit;
  end;

  if frmConnProps.ShowModal = mrOk then
  begin
    FClientSocket.Host := frmConnProps.editHost.Text;
    FClientSocket.Port := StrToIntDef(frmConnProps.editPort.Text, 443);
    if frmConnProps.cbBlocking.Checked then
      FClientSocket.ClientType := ctBlocking
    else
      FClientSocket.ClientType := ctNonBlocking;
    FClientSocket.Versions := [];
    if frmConnProps.cbSSL2.Checked then
      FClientSocket.Versions := FClientSocket.Versions + [sbSSL2];
    if frmConnProps.cbSSL3.Checked then
      FClientSocket.Versions := FClientSocket.Versions + [sbSSL3];
    if frmConnProps.cbTLS1.Checked then
      FClientSocket.Versions := FClientSocket.Versions + [sbTLS1];
    if frmConnProps.cbTLS11.Checked then
      FClientSocket.Versions := FClientSocket.Versions + [sbTLS11];
    FClientSocket.CompressionAlgorithms[SSL_CA_ZLIB]:=frmConnProps.cbUseCompression.Checked;
    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 ' + FClientSocket.Host + ':' + IntToStr(FClientSocket.Port), false);
    FClientSocket.Passthrough := frmConnProps.cbClear.Checked;
    if FClientSocket.ClientType = ctBlocking then
      Log('Mode: Blocking', false)
    else
      Log('Mode: Non-blocking', false);
    FNeededIndex := 0;
    ElMemoryCertStorage.Clear;
    memoOutput.Clear;
    lvLog.Items.Clear;
    if FClientSocket.ClientType = ctBlocking then
      ConnectBlocking
    else
      ConnectNonBlocking;
  end;
end;

procedure TfrmMain.ConnectBlocking;
var
  S: string;
  Strm : TElSecureSocketStream;
  Read: integer;
begin
  try
    FClientSocket.Open;
  except
    on E: Exception do
    begin
      Log('Failed to establish connection: ' + E.Message, true);
      Exit;
    end;
  end;

  Strm := TElSecureSocketStream.Create(FClientSocket.Socket, 5000);
  try
    S := 'GET / HTTP/1.0'#13#10'Connection: close'#13#10#13#10;
    Strm.Write(S[1], Length(S));

    Strm.Timeout := 1000;

    while FClientSocket.Socket.Connected{ and FClientSocket.Socket.Encrypted} do
    begin
      if Strm.WaitForData(500) then
      begin
        SetLength(S, $ffff);
        Read := Strm.Read(S[1], Length(S));
        SetLength(S, Read);
        memoOutput.Lines.Text := memoOutput.Lines.Text + S;
      end;
      Application.ProcessMessages;
    end;
  finally
    Strm.Free;
  end;
end;

procedure TfrmMain.ConnectNonBlocking;
begin
  FClientSocket.Open;
end;

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

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

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

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

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

procedure TfrmMain.SetupEvents;
begin
  FClientSocket.OnCertificateValidate := ClientSocketCertificateValidate;
  FClientSocket.OnCertificateNeededEx := ClientSocketCertificateNeededEx;
  FClientSocket.OnSSLEstablished := ClientSocketSSLEstablished;
  FClientSocket.OnSSLClose := ClientSocketSSLClose;
  FClientSocket.OnSSLError := ClientSocketSSLError;
  FClientSocket.OnConnect := ClientSocketConnect;
  FClientSocket.OnDisconnect := ClientSocketDisconnect;
  FClientSocket.OnRead := ClientSocketRead;
  FClientSocket.OnError := ClientSocketError;
end;

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

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

procedure TfrmMain.ClientSocketCertificateValidate(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);
  FClientSocket.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.ClientSocketCertificateNeededEx(Sender: TObject;
  var Certificate: TElX509Certificate);
begin
  if (FUseCert) and (FNeededIndex = 0) then
  begin
    Certificate := FCert;
    Inc(FNeededIndex);
  end
  else
    Certificate := nil;
end;

procedure TfrmMain.ClientSocketSSLEstablished(Sender : TObject; Version : TSBVersion;
  CipherSuite : TSBCipherSuite);
var
  S: string;
begin
  Log('SSL connection established', false);
  case Version 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;
  FClientSocket.Socket.SendText(S);
end;

procedure TfrmMain.ClientSocketSSLClose(Sender: TObject);
begin
  Log('SSL connection closed', false);
end;

procedure TfrmMain.ClientSocketConnect(Sender: TObject; Socket: TCustomWinSocket);
begin
  Log('TCP connection established', false);
  if FClientSocket.PassThrough then
  begin
    Log('Sending HTTP request in clear', false);
    FClientSocket.Socket.SendText('GET / HTTP/1.0'#13#10'Connection: close'#13#10#13#10);
  end;
end;

procedure TfrmMain.ClientSocketDisconnect(Sender: TObject; Socket: TCustomWinSocket);
begin
  Log('TCP connection closed', false);
end;

procedure TfrmMain.ClientSocketRead(Sender: TObject; Socket: TCustomWinSocket);
var
  S: string;
begin
  S := TElSecureClientWinSocket(Socket).ReceiveText;
  memoOutput.Lines.Text := memoOutput.Lines.Text + S;
end;

procedure TfrmMain.ClientSocketError(Sender: TObject; Socket: TCustomWinSocket;
  ErrorEvent: TErrorEvent; var ErrorCode: Integer);
begin
  Log('Socket error ' + IntToStr(ErrorCode), true);
end;


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

procedure TfrmMain.ClientSocketSSLError(Sender: TObject;
  ErrorCode: integer; Fatal, Remote: boolean);
begin
  ;
end;


initialization

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

end.