mainform.pas

著名的SecureBlackBox控件完整源码

unit MainForm;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, ComCtrls, ExtCtrls, Grids, Winsock, SBX509,
  SBCustomCertStorage, SBSSLCommon, SBServer, SBDTLSServer, ImgList,
  SBUtils;

type
  TfrmMain = class(TForm)
    gbConnProps: TGroupBox;
    lblPort: TLabel;
    editPort: TEdit;
    lblUsername: TLabel;
    editUsername: TEdit;
    lblServerCert: TLabel;
    lblSelectCert: TLabel;
    btnListen: TButton;
    pLog: TPanel;
    lvLog: TListView;
    pSendBox: TPanel;
    editTextToSend: TEdit;
    btnSend: TButton;
    pClient: TPanel;
    Server: TElDTLSServer;
    CertStorage: TElMemoryCertStorage;
    OpenDialog: TOpenDialog;
    Timer: TTimer;
    imgListLog: TImageList;
    cbUseClientAuth: TCheckBox;
    lvChatData: TListView;
    imgListChat: TImageList;
    procedure FormCreate(Sender: TObject);
    procedure ServerCertificateValidate(Sender: TObject;
      X509Certificate: TElX509Certificate; var Validate: Boolean);
    procedure ServerCiphersNegotiated(Sender: TObject);
    procedure ServerCloseConnection(Sender: TObject;
      CloseDescription: Integer);
    procedure ServerData(Sender: TObject; Buffer: Pointer; Size: Integer);
    procedure ServerError(Sender: TObject; ErrorCode: Integer; Fatal,
      Remote: Boolean);
    procedure ServerOpenConnection(Sender: TObject);
    procedure ServerReceive(Sender: TObject; Buffer: Pointer;
      MaxSize: Integer; out Written: Integer);
    procedure ServerSend(Sender: TObject; Buffer: Pointer; Size: Integer);
    procedure TimerTimer(Sender: TObject);
    procedure lblSelectCertClick(Sender: TObject);
    procedure btnListenClick(Sender: TObject);
    procedure btnSendClick(Sender: TObject);
  private
    FSocket : integer;
    FAddr : SOCKADDR_IN;
    procedure Log(const S : string; Error : boolean = false);
    procedure LoadCertificate;
    function RequestPassphrase: string;
    procedure AddChatMessage(const S : string; Remote : boolean = true);
  public
    { Public declarations }
  end;

var
  frmMain: TfrmMain;

implementation

uses PassReqForm;

{$R *.DFM}

procedure TfrmMain.LoadCertificate;
var
  Pass : string;
  Cert : TElX509Certificate;
  F : TFileStream;
  R : integer;
begin
  if OpenDialog.Execute then
  begin
    Pass := RequestPassphrase();
    Cert := TElX509Certificate.Create(nil);
    try
      F := TFileStream.Create(OpenDialog.Filename, fmOpenRead);
      try
        R := Cert.LoadFromStreamPFX(F, Pass);
        if R = 0 then
        begin
          CertStorage.Clear;
          CertStorage.Add(Cert);
          lblSelectCert.Caption := 'CN=' + Cert.SubjectName.CommonName;
        end
        else
          MessageDlg('Failed to load certificate, error ' + IntToHex(R, 4),
            mtError, [mbOk], 0);
      finally
        FreeAndNil(F);
      end;
    finally
      FreeAndNil(Cert);
    end;
  end;
end;

function TfrmMain.RequestPassphrase: string;
begin
  frmPassReq.editPassphrase.Text := '';
  if frmPassReq.ShowModal = mrOk then
    Result := frmPassReq.editPassphrase.Text
  else
    Result := '';
end;

procedure TfrmMain.AddChatMessage(const S : string; Remote : boolean = true);
var
  Item: TListItem;
  Index : integer;
  Username, Text : string;
begin
  Item := lvChatData.Items.Add;
  Index := Pos(#13#10, S);
  Username := Copy(S, 1, Index - 1);
  Text := Copy(S, Index + 2, Length(S));
  Item.Caption := Username;
  Item.SubItems.Add(Text);
  if Remote then
    Item.ImageIndex := 1
  else
    Item.ImageIndex := 0;
end;

procedure TfrmMain.Log(const S : string; Error : boolean = false);
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.FormCreate(Sender: TObject);
var
  Data : WSAData;
begin
  FSocket := 0;
  WSAStartup(MAKEWORD(2, 2), Data);
end;

procedure TfrmMain.ServerCertificateValidate(Sender: TObject;
  X509Certificate: TElX509Certificate; var Validate: Boolean);
begin
  Log('Client certificate received');
  Log('Certificate owner: ' + X509Certificate.SubjectName.CommonName);
  Validate := true;
end;

procedure TfrmMain.ServerCiphersNegotiated(Sender: TObject);
begin
  Log('New ciphers negotiated');
end;

procedure TfrmMain.ServerCloseConnection(Sender: TObject;
  CloseDescription: Integer);
begin
  Log('Connection closed');
  btnSend.Enabled := false;
  Timer.Enabled := false;
end;

procedure TfrmMain.ServerData(Sender: TObject; Buffer: Pointer;
  Size: Integer);
var
  S : string;
begin
  SetLength(S, Size);
  Move(Buffer^, S[1], Length(S));
  AddChatMessage(S, true);
end;

procedure TfrmMain.ServerError(Sender: TObject; ErrorCode: Integer; Fatal,
  Remote: Boolean);
begin
  Log('Protocol flow error 0x' + IntToHex(ErrorCode, 8), true);
  Timer.Enabled := false;
end;

procedure TfrmMain.ServerOpenConnection(Sender: TObject);
begin
  Log('Connection opened');
  btnSend.Enabled := true;
end;

procedure TfrmMain.ServerReceive(Sender: TObject; Buffer: Pointer;
  MaxSize: Integer; out Written: Integer);
var
  AddrLen : integer;
begin
  AddrLen := SizeOf(FAddr);
  Written := recvfrom(FSocket, Buffer^, MaxSize, 0, FAddr, AddrLen);
  if Written = SOCKET_ERROR then
  begin
    Log('recvfrom() call failed, error ' + IntToStr(GetLastError), true);
    Timer.Enabled := false;
  end;
end;

procedure TfrmMain.ServerSend(Sender: TObject; Buffer: Pointer;
  Size: Integer);
var
  R : integer;
begin
  R := sendto(FSocket, Buffer^, Size, 0, FAddr, sizeof(FAddr));
  if R = SOCKET_ERROR then
    Log('sendto() call failed, error ' + IntToStr(GetLastError), true)
  else if R < Size then
    Log('sendto() failed to send the complete amount of data (wrong MTU?)', true);
  if R <> Size then
    Timer.Enabled := false;
end;

procedure TfrmMain.TimerTimer(Sender: TObject);
var
  FDSet : TFDSet;
  TV : TTimeVal;
begin
  FD_ZERO(FDSet);
  FD_SET(FSocket, FDSet);
  TV.tv_sec := 0;
  TV.tv_usec := 0;
  if (select(FSocket + 1, @FDSet, nil, nil, @TV) > 0) then
    Server.DataAvailable;
end;

procedure TfrmMain.lblSelectCertClick(Sender: TObject);
begin
  LoadCertificate();
end;

procedure TfrmMain.btnListenClick(Sender: TObject);
var
  Addr : SOCKADDR_IN;
  R : integer;
begin
  if CertStorage.Count < 1 then
  begin
    MessageDlg('No certificate selected', mtError, [mbOk], 0);
    Exit;
  end;
  Log('Listening for incoming connections...');
  FSocket := socket(AF_INET, SOCK_DGRAM, IPPROTO_UDP);
  if (FSocket = 0) or (FSocket = SOCKET_ERROR) then
  begin
    Log('Failed to create socket, error ' + IntToStr(GetLastError), true);
    Exit;
  end;
  FillChar(Addr, SizeOf(addr), 0);
  Addr.sin_addr.S_addr := INADDR_ANY;
  Addr.sin_port := htons(StrToInt(editPort.Text));
  Addr.sin_family := AF_INET;
  R := bind(FSocket, Addr, SizeOf(Addr));
  if R <> 0 then
  begin
    Log('Failed to bind socket, error ' + IntToStr(GetLastError), true);
    Exit;
  end;
  if cbUseClientAuth.Checked then
  begin
    Server.ClientAuthentication := true;
    Server.AuthenticationLevel := alRequireCert;
  end
  else
    Server.ClientAuthentication := false;
  Server.Open;
  Timer.Enabled := true;
  btnListen.Enabled := false;
end;

procedure TfrmMain.btnSendClick(Sender: TObject);
var
  Msg : string;
begin
  if Server.Active then
  begin
    Msg := editUsername.Text + #13#10 + editTextToSend.Text;
    Server.SendText(Msg);
    AddChatMessage(Msg, false);
  end
  else
    Log('Not connected', true);
  editTextToSend.Text := '';
end;

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

end.