client_form.pas

著名的SecureBlackBox控件完整源码

unit Client_Form;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  Dialogs, ExtCtrls, ComCtrls, StdCtrls,

{$IFDEF VER120}
  FileCtrl,
{$ENDIF}
{$IFDEF VER130}
  FileCtrl,
{$ENDIF}

  rtcInfo, rtcConn,
  rtcHttpCli, rtcDataCli, rtcPlugins, SBRTCClientPlugin, SBX509,
  SBCustomCertStorage, SBRTCPlugin;

type
  TRtcFileClient = class(TForm)
    Client: TRtcHttpClient;
    DataRequest: TRtcDataRequest;
    Panel1: TPanel;
    Panel2: TPanel;
    Panel3: TPanel;
    Panel5: TPanel;
    btnConnect: TButton;
    btnDisconnect: TButton;
    btnPost: TButton;
    Panel6: TPanel;
    Splitter1: TSplitter;
    Panel7: TPanel;
    Panel8: TPanel;
    Splitter2: TSplitter;
    Panel9: TPanel;
    Panel10: TPanel;
    Panel11: TPanel;
    Panel12: TPanel;
    Label4: TLabel;
    eResponseHeader: TMemo;
    lblBytes: TLabel;
    btn100Post: TButton;
    lblCount: TLabel;
    btnCancelAll: TButton;
    pBar: TProgressBar;
    lblRetry: TLabel;
    Label7: TLabel;
    eReqMethod: TEdit;
    Label8: TLabel;
    eReqFileName: TEdit;
    Label10: TLabel;
    lblSpeed: TLabel;
    Label11: TLabel;
    eReqQuery: TEdit;
    eResponseBody: TMemo;
    lblTime: TLabel;
    Label6: TLabel;
    SaveDialog1: TSaveDialog;
    xSaveToFile: TCheckBox;
    eFileName: TEdit;
    btnSaveAs: TButton;
    Label9: TLabel;
    eReqHost: TEdit;
    Label3: TLabel;
    Label2: TLabel;
    Label1: TLabel;
    ePort: TEdit;
    eAddr: TEdit;
    xUseProxy: TCheckBox;
    xThreads: TCheckBox;
    xUseSSL: TCheckBox;
    xAutoConnect: TCheckBox;
    xReconError: TCheckBox;
    Label5: TLabel;
    xReconFail: TCheckBox;
    xReconLost: TCheckBox;
    xShowWarning: TCheckBox;
    Label12: TLabel;
    lblDataInOut: TLabel;
    SSLCrypt: TSSLClientRtcCryptPlugin;
    CertStorage: TElMemoryCertStorage;
    procedure btnPostClick(Sender: TObject);
    procedure btnConnectClick(Sender: TObject);
    procedure btnDisconnectClick(Sender: TObject);
    procedure ClientConnect(Sender: TRtcConnection);
    procedure ClientDisconnect(Sender: TRtcConnection);
    procedure DataRequestBeginRequest(Sender: TRtcConnection);
    procedure DataRequestDataReceived(Sender: TRtcConnection);
    procedure DataRequestRepostCheck(Sender: TRtcConnection);
    procedure btn100PostClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure btnCancelAllClick(Sender: TObject);
    procedure xUseProxyClick(Sender: TObject);
    procedure ClientConnectFail(Sender: TRtcConnection);
    procedure xThreadsClick(Sender: TObject);
    procedure eAddrChange(Sender: TObject);
    procedure xUseSSLClick(Sender: TObject);
    procedure ePortChange(Sender: TObject);
    procedure xAutoConnectClick(Sender: TObject);
    procedure btnSaveAsClick(Sender: TObject);
    procedure eReqFileNameChange(Sender: TObject);
    procedure xReconLostClick(Sender: TObject);
    procedure xReconFailClick(Sender: TObject);
    procedure xReconErrorClick(Sender: TObject);
    procedure ClientDataIn(Sender: TRtcConnection);
    procedure ClientDataOut(Sender: TRtcConnection);
    procedure DataRequestResponseAbort(Sender: TRtcConnection);
    procedure SSLCryptCertificateValidate(Sender: TObject;
      X509Certificate: TElX509Certificate; Handler: TSSLRtcHandler;
      var Validate: Boolean);
  private
    { Private declarations }
  public
    Cnt:integer;
    TotalDataIn,TotalDataOut:int64;
    TimeStart,TimeNow,TimeCnt,TimeSum,
    TimeMin,TimeMax:cardinal;
    TimeAvg:Extended;
    Ret:integer;
    { Public declarations }
  end;

var
  RtcFileClient: TRtcFileClient;

implementation

{$R *.dfm}

procedure TRtcFileClient.btnPostClick(Sender: TObject);
  begin
  with DataRequest do
    begin
    with Request do
      begin
      Method:=eReqMethod.Text;
      FileName:='/'+eReqFileName.Text;
      Query.Text:=eReqQuery.Text;
      Host:=eReqHost.Text;
      if xSaveToFile.Checked then
        Info.asString['fname']:=eFileName.Text;
      end;
    Post;
    end;
  end;

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

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

procedure TRtcFileClient.ClientConnect(Sender: TRtcConnection);
  begin
  if not Sender.inMainThread then
    Sender.Sync(ClientConnect)
  else
    begin
    btnConnect.Enabled:=False;
    btnDisconnect.Enabled:=True;
    end;
  end;

procedure TRtcFileClient.ClientDisconnect(Sender: TRtcConnection);
  begin
  if not Sender.inMainThread then
    Sender.Sync(ClientDisconnect)
  else
    begin
    btnConnect.Enabled:=True;
    btnDisconnect.Enabled:=False;
    end;
  end;

procedure TRtcFileClient.DataRequestBeginRequest(Sender: TRtcConnection);
  begin
  with TRtcDataClient(Sender) do
    begin
    TimeStart:=GetTickCount;
    WriteHeader;
    // No Body.
    end;
  end;

procedure TRtcFileClient.DataRequestDataReceived(Sender: TRtcConnection);
  var
    s:string;
  begin
  with TRtcDataClient(Sender) do
    if not inMainThread then
      Sync(DataRequestDataReceived)
    else
      begin
      TimeNow:=GetTickCount-TimeStart;
      if TimeNow>1000 then
        lblSpeed.Caption:=IntToStr(Response.ContentIn*8 div TimeNow)+'Kbit/s'
      else
        lblSpeed.Caption:='???';

      if Response.Started then
        begin
        eResponseHeader.Text:='Status: '+IntToStr(Response.StatusCode)+' '+
                              Response.StatusText+#13#10+
                              Response.HeaderText;
        eResponseBody.Text:='';
        if Request.info.asString['fname']<>'' then
          begin
          if not DirectoryExists(ExtractFilePath(ExpandFileName(Request.info.asString['fname']))) then
            CreateDir(ExtractFilePath(ExpandFileName(Request.info.asString['fname'])));
          Delete_File(request.Info.asString['fname']);
          end;
        end;

      lblBytes.Caption:=IntToStr(Response.ContentIn)+' Byte(s)';

      if Request.Info.asString['fname']<>'' then
        begin
        s:=Read;
        Write_File(Request.Info.asString['fname'], s, Response.ContentIn-length(s));
        end;

      if not Response.Done then
        begin
        if Response.ContentLength>0 then
          begin
          pBar.Max:=100;
          pBar.Position:=round(Response.ContentIn/Response.ContentLength*100);
          end
        else
          begin
          pBar.Max:=100;
          pBar.Position:=50;
          end;
        Update;
        end
      else
        begin
        TimeCnt:=TimeCnt+1;
        if (TimeMin=0) or (TimeNow<TimeMin) then
          TimeMin:=TimeNow;
        if (TimeMax=0) or (TimeNow>TimeMax) then
          TimeMax:=TimeNow;
        TimeSum:=TimeSum+TimeNow;

        TimeAvg:=round(TimeSum*100/TimeCnt)/100;

        lblTime.Caption:='Time: '+
                         IntToStr(TimeMin)+' < '+
                         FloatToStr(TimeAvg)+' < '+
                         IntToStr(TimeMax)+' ms';

        Inc(Cnt);
        lblCount.Caption:=IntToStr(Cnt)+' received, '+
                          IntToStr(RequestCount-1)+' waiting.';

        if Request.info.asString['fname']<>'' then
          eResponseBody.Text:='Saved to "'+Request.info.asString['fname']+'" ...'#13#10+
                               Read_File(Request.info.asString['fname'],0,65535)
        else
          begin
          s:=Read;
          eResponseBody.Text:=s;
          end;

        pBar.Max:=100;
        pBar.Position:=pBar.Max;
        Update;
        end;
      end;
  end;

procedure TRtcFileClient.DataRequestRepostCheck(Sender: TRtcConnection);
  begin
  with TRtcDataClient(Sender) do
    if not inMainThread then
      Sync(DataRequestRepostCheck)
    else
      begin
       // We aren't using the AutoRepost property, so we can count the number of reposts here.
      Inc(Ret);
      lblRetry.Caption:=IntToStr(Ret)+' Reposts.';
      lblCount.Caption:=IntToStr(Cnt)+' received, '+
                        IntToStr(RequestCount)+' waiting.';
      if xShowWarning.Checked and (Request.Reposted>5) then
        begin
        ShowMessage('Last request was reposted 5 times without success.'#13#10+
                    'Please, check your internet settings and try again.');
        { Since we aren't calling "Request.Repost", all pending requests will be canceled. }
        end
      else
        Request.Repost; // We need to call this if we want the Request to be sent once more.
      end;
  end;

procedure TRtcFileClient.btn100PostClick(Sender: TObject);
  var
    a:integer;
  begin
  for a:=1 to 100 do
    btnPostClick(Sender);
  end;

procedure TRtcFileClient.FormCreate(Sender: TObject);
  begin
  TotalDataIn:=0;
  TotalDataOut:=0;
  
  TimeStart:=0;
  TimeCnt:=0;
  TimeSum:=0;
  TimeMin:=0;
  TimeMax:=0;

  Cnt:=0;
  Ret:=0;
  end;

procedure TRtcFileClient.btnCancelAllClick(Sender: TObject);
  begin
  Client.SkipRequests;

  TimeStart:=0;
  TimeCnt:=0;
  TimeSum:=0;
  TimeMin:=0;
  TimeMax:=0;

  Cnt:=0;
  Ret:=0;

  eResponseHeader.Text:='';
  eResponseBody.Text:='';
  lblTime.Caption:='Time: 0 ms';
  lblCount.Caption:='0 Received.';
  lblRetry.Caption:='0 Reposts.';
  lblBytes.Caption:='0 Bytes';
  pBar.Max:=100;
  pBar.Position:=0;
  end;

procedure TRtcFileClient.xUseProxyClick(Sender: TObject);
  begin
  Client.Disconnect;
  try
    Client.UseProxy:=xUseProxy.Checked;
  finally
    xUseProxy.Checked:=Client.UseProxy;
    end;
  end;

procedure TRtcFileClient.ClientConnectFail(Sender: TRtcConnection);
  begin
  if not TRtcDataClient(Sender).ReconnectOn.ConnectFail then
    if not Sender.inMainThread then
      Sender.Sync(ClientConnectFail)
    else
      ShowMessage('Failed to connect to Server.');
  end;

procedure TRtcFileClient.xThreadsClick(Sender: TObject);
  begin
  Client.Disconnect;
  try
    Client.MultiThreaded:=xThreads.Checked;
  finally
    xThreads.Checked:=Client.MultiThreaded;
    end;
  end;

procedure TRtcFileClient.eAddrChange(Sender: TObject);
  begin
  Client.Disconnect;
  Client.ServerAddr:=eAddr.Text;
  eReqHost.Text:=eAddr.Text;
  end;

procedure TRtcFileClient.xUseSSLClick(Sender: TObject);
  begin
  Client.Disconnect;
  try
    Client.UseSSL:=xUseSSL.Checked;
  finally
    xUseSSL.Checked:=Client.UseSSL;
    end;
  if xUseSSL.Checked then
    ePort.Text:='443'
  else
    ePort.Text:='80';
  end;

procedure TRtcFileClient.ePortChange(Sender: TObject);
  begin
  Client.Disconnect;
  Client.ServerPort:=ePort.Text;
  end;

procedure TRtcFileClient.xAutoConnectClick(Sender: TObject);
  begin
  Client.Disconnect;
  try
    Client.AutoConnect:=xAutoConnect.Checked;
  finally
    xAutoConnect.Checked:=Client.AutoConnect;
    end;
  end;

procedure TRtcFileClient.btnSaveAsClick(Sender: TObject);
  begin
  SaveDialog1.InitialDir:=ExtractFilePath(eFileName.Text);
  SaveDialog1.FileName:=ExtractFileName(eFileName.Text);
  if SaveDialog1.Execute then
    begin
    xSaveToFile.Checked:=True;
    eFileName.Text:=SaveDialog1.FileName;
    end;
  end;

procedure TRtcFileClient.eReqFileNameChange(Sender: TObject);
  begin
  eFileName.Text:=ExtractFilePath(eFileName.Text)+
                  ExtractFileName(StringReplace(eReqFileName.Text,'/','\',[rfReplaceAll]));
  if ExtractFileName(eFileName.Text)='' then
    eFileName.Text:=eFileName.Text+'index.htm';
  end;

procedure TRtcFileClient.xReconLostClick(Sender: TObject);
  begin
  Client.ReconnectOn.ConnectLost:=xReconLost.Checked;
  end;

procedure TRtcFileClient.xReconFailClick(Sender: TObject);
  begin
  Client.ReconnectOn.ConnectFail:=xReconFail.Checked;
  end;

procedure TRtcFileClient.xReconErrorClick(Sender: TObject);
  begin
  Client.ReconnectOn.ConnectError:=xReconError.Checked;
  end;

procedure TRtcFileClient.ClientDataIn(Sender: TRtcConnection);
  begin
  if not Sender.inMainThread then
    Sender.Sync(ClientDataIn)
  else
    begin
    TotalDataIn:=TotalDataIn+Sender.DataIn;
    lblDataInOut.Caption:=IntToStr(TotalDataIn)+' + '+IntToStr(TotalDataOut)+' bytes';
    end;
  end;

procedure TRtcFileClient.ClientDataOut(Sender: TRtcConnection);
  begin
  if not Sender.inMainThread then
    Sender.Sync(ClientDataOut)
  else
    begin
    TotalDataOut:=TotalDataOut+Sender.DataOut;
    lblDataInOut.Caption:=IntToStr(TotalDataIn)+' + '+IntToStr(TotalDataOut)+' bytes';
    end;
  end;
procedure TRtcFileClient.DataRequestResponseAbort(Sender: TRtcConnection);
  begin
  with TRtcDataClient(Sender) do
    if not inMainThread then
      Sync(DataRequestRepostCheck)
    else
      begin
      // This request was aborted, update our "waiting" display ...
      lblCount.Caption:=IntToStr(Cnt)+' received, '+
                        IntToStr(RequestCount-1)+' waiting.';
      lblCount.Update;
      end;
  end;


procedure TRtcFileClient.SSLCryptCertificateValidate(Sender: TObject;
  X509Certificate: TElX509Certificate; Handler: TSSLRtcHandler;
  var Validate: Boolean);
begin
  Validate := true; // NEVER do this in production code. Instead perform full certificate validation
end;

end.